From e6c71b52d5c19c126023f05fe0c06952dd5248ba Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Fri, 3 Jun 2022 19:15:01 +0200 Subject: [PATCH 1/4] Proto/Scoru: parameters_type returns an option --- src/proto_alpha/lib_protocol/alpha_context.mli | 2 +- src/proto_alpha/lib_protocol/sc_rollup_storage.ml | 8 +++----- src/proto_alpha/lib_protocol/sc_rollup_storage.mli | 5 ++--- .../test/integration/operations/test_sc_rollup.ml | 1 + 4 files changed, 7 insertions(+), 9 deletions(-) diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 70ff62e9a81d..4bec9da2407a 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -2724,7 +2724,7 @@ module Sc_rollup : sig (t * Z.t * context) tzresult Lwt.t val parameters_type : - context -> t -> (Script.lazy_expr * context) tzresult Lwt.t + context -> t -> (Script.lazy_expr option * context) tzresult Lwt.t val kind : context -> t -> Kind.t option tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/sc_rollup_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_storage.ml index 7a7c34e7180e..06a0fea1999d 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_storage.ml @@ -76,11 +76,9 @@ let get_boot_sector ctxt rollup = | Some boot_sector -> return boot_sector let parameters_type ctxt rollup = - let open Lwt_tzresult_syntax in - let* ctxt, res = Store.Parameters_type.find ctxt rollup in - match res with - | None -> fail (Sc_rollup_does_not_exist rollup) - | Some x -> return (x, ctxt) + let open Lwt_result_syntax in + let+ ctxt, res = Store.Parameters_type.find ctxt rollup in + (res, ctxt) module Outbox = struct let level_index ctxt level = diff --git a/src/proto_alpha/lib_protocol/sc_rollup_storage.mli b/src/proto_alpha/lib_protocol/sc_rollup_storage.mli index b4bd156ee3d6..2dca63488e63 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_storage.mli +++ b/src/proto_alpha/lib_protocol/sc_rollup_storage.mli @@ -55,12 +55,11 @@ val initial_level : val get_boot_sector : Raw_context.t -> Sc_rollup_repr.t -> string tzresult Lwt.t (** [parameters_type ctxt rollup] returns the registered type of a rollup. - Fails with an [Sc_rollup_does_not_exist] error in case there is no - registered type for the rollup. *) + Returns [None] in case there is no registered type for the rollup. *) val parameters_type : Raw_context.t -> Sc_rollup_repr.t -> - (Script_repr.lazy_expr * Raw_context.t) tzresult Lwt.t + (Script_repr.lazy_expr option * Raw_context.t) tzresult Lwt.t (** A module for managing state concerning a rollup's outbox. *) module Outbox : sig diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml index 2ff1efceb437..5de4f4701011 100644 --- a/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml +++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml @@ -428,6 +428,7 @@ let test_originating_with_valid_type () = let* incr = Incremental.begin_construction block in let ctxt = Incremental.alpha_ctxt incr in let* expr, _ctxt = wrap @@ Sc_rollup.parameters_type ctxt rollup in + let expr = WithExceptions.Option.get ~loc:__LOC__ expr in let*? expr, _ctxt = Environment.wrap_tzresult @@ Script.force_decode_in_context -- GitLab From 1d7a332916214e49231c58e1dff68202c3c0c67b Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Fri, 3 Jun 2022 19:25:28 +0200 Subject: [PATCH 2/4] Proto/Sc_rollup: expose chosen errors --- src/proto_alpha/lib_protocol/alpha_context.ml | 2 ++ src/proto_alpha/lib_protocol/alpha_context.mli | 4 ++++ 2 files changed, 6 insertions(+) diff --git a/src/proto_alpha/lib_protocol/alpha_context.ml b/src/proto_alpha/lib_protocol/alpha_context.ml index 86775bd3fb12..f1e852c2f6ee 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.ml +++ b/src/proto_alpha/lib_protocol/alpha_context.ml @@ -83,6 +83,8 @@ module Sc_rollup = struct include Sc_rollup_storage.Outbox module Message = Sc_rollup_outbox_message_repr end + + module Errors = Sc_rollup_errors end module Dal = struct diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 4bec9da2407a..b67f5ff119f9 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -3031,6 +3031,10 @@ module Sc_rollup : sig (Z.t * context) tzresult Lwt.t end + module Errors : sig + type error += Sc_rollup_does_not_exist of t + end + module Internal_for_tests : sig val originated_sc_rollup : Origination_nonce.Internal_for_tests.t -> t end -- GitLab From 996eb3ac399e052f00dae7761c8709781a2d086a Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Tue, 24 May 2022 10:23:17 +0200 Subject: [PATCH 3/4] Proto/Michelson: implement CONTRACT for SCORU addresses Fixes #2800 --- .../lib_protocol/script_ir_translator.ml | 39 +++++++++++++++++-- 1 file changed, 35 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 ec4aecbc3fd1..58f525f87417 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -5019,10 +5019,41 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra error ctxt (fun loc -> Tx_rollup_bad_deposit_parameter (loc, serialize_ty_for_error arg)) else error ctxt (fun _loc -> No_such_entrypoint entrypoint) - | Sc_rollup _ -> - (* TODO #2800 - Implement typechecking of sc rollup deposits. *) - return (error ctxt (fun _loc -> No_such_entrypoint entrypoint)) + | Sc_rollup sc_rollup -> + Sc_rollup.parameters_type ctxt sc_rollup + >>=? fun (parameters_type, ctxt) -> + Lwt.return + (match parameters_type with + | None -> + ok + (error ctxt (fun _loc -> + Sc_rollup.Errors.Sc_rollup_does_not_exist sc_rollup)) + | Some parameters_type -> + Script.force_decode_in_context + ~consume_deserialization_gas:When_needed + ctxt + parameters_type + >>? fun (parameters_type, ctxt) -> + parse_parameter_ty_and_entrypoints + ctxt + ~stack_depth:(stack_depth + 1) + ~legacy:true + (root parameters_type) + >>? fun ( Ex_parameter_ty_and_entrypoints + {arg_type = full; entrypoints}, + ctxt ) -> + Gas_monad.run ctxt + @@ find_entrypoint_for_type + ~error_details + ~full + ~expected:arg + entrypoints + entrypoint + >|? fun (entrypoint_arg, ctxt) -> + ( ctxt, + entrypoint_arg >|? fun (entrypoint, arg_ty) -> + let address = {destination; entrypoint} in + Typed_contract {arg_ty; address} )) (* Same as [parse_contract], but does not fail when the contact is missing or if the expected type doesn't match the actual one. In that case None is -- GitLab From fccbf3b640bcd477ac73841ca97eb06fa8fa2655 Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Wed, 8 Jun 2022 15:09:03 +0100 Subject: [PATCH 4/4] Test/Michelson: test parse-contract-data for sc rollups --- .../michelson/test_typechecking.ml | 149 ++++++++++++++++++ 1 file changed, 149 insertions(+) diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml index 3aee56eb04df..e1c7060734b0 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml @@ -38,6 +38,32 @@ open Error_monad_operators let wrap_error_lwt x = x >>= fun x -> Lwt.return @@ Environment.wrap_tzresult x +let context_init_with_sc_rollup_enabled tup = + Context.init_with_constants_gen + tup + { + Context.default_test_constants with + consensus_threshold = 0; + sc_rollup = {Context.default_test_constants.sc_rollup with enable = true}; + } + +let sc_originate block contract parameters_ty = + let open Lwt_result_syntax in + let kind = Sc_rollup.Kind.Example_arith in + let* operation, rollup = + Op.sc_rollup_origination + ~counter:(Z.of_int 0) + (B block) + contract + kind + "" + (Script.lazy_expr @@ Expr.from_string parameters_ty) + in + let* incr = Incremental.begin_construction block in + let* incr = Incremental.add_operation incr operation in + let* block = Incremental.finalize_block incr in + return (block, rollup) + (* Test for Script_ir_translator.parse_and_unparse_script_unaccounted on a script declaring views. *) let test_unparse_view () = @@ -760,6 +786,117 @@ let test_forbidden_op_in_view op () = op | Error _ -> return_unit +(** Test [parse_contract_data] for rollup with unit type. *) +let test_parse_contract_data_for_unit_rollup () = + let open Lwt_result_syntax in + let* block, (contract, _) = context_init_with_sc_rollup_enabled T2 in + let* block, rollup = sc_originate block contract "unit" in + let* incr = Incremental.begin_construction block in + let ctxt = Incremental.alpha_ctxt incr in + let* ( _ctxt, + Typed_contract + { + arg_ty = Script_typed_ir.Unit_t; + address = {destination; entrypoint}; + } ) = + wrap_error_lwt + @@ Script_ir_translator.parse_contract_data + ctxt + (-1) + Script_typed_ir.unit_t + (Destination.Sc_rollup rollup) + ~entrypoint:Entrypoint.default + in + (* Check that the destinations match. *) + let* () = + Assert.equal_string + ~loc:__LOC__ + (Destination.to_b58check destination) + (Sc_rollup.Address.to_b58check rollup) + in + (* Check that entrypoints match. *) + let* () = + Assert.equal_string ~loc:__LOC__ (Entrypoint.to_string entrypoint) "default" + in + return () + +(** Test [parse_contract_data] for rollup with entrypoints in type. *) +let test_parse_contract_data_for_rollup_with_entrypoints () = + let open Lwt_result_syntax in + let* block, (contract, _) = context_init_with_sc_rollup_enabled T2 in + let* block, rollup = + sc_originate block contract "or (pair %add nat nat) (unit %reset)" + in + let rollup_destination = Sc_rollup.Address.to_b58check rollup in + let* incr = Incremental.begin_construction block in + let ctxt = Incremental.alpha_ctxt incr in + let* ctxt, Typed_contract {arg_ty = _; address = {destination; entrypoint}} = + let*? (Script_typed_ir.Ty_ex_c nat_pair) = + Environment.wrap_tzresult Script_typed_ir.(pair_t (-1) nat_t nat_t) + in + wrap_error_lwt + @@ Script_ir_translator.parse_contract_data + ctxt + (-1) + nat_pair + (Destination.Sc_rollup rollup) + ~entrypoint:(Entrypoint.of_string_strict_exn "add") + in + (* Check that the destinations match. *) + let* () = + Assert.equal_string + ~loc:__LOC__ + (Destination.to_b58check destination) + rollup_destination + in + (* Check that entrypoints match. *) + let* () = + Assert.equal_string ~loc:__LOC__ (Entrypoint.to_string entrypoint) "add" + in + let* _ctxt, Typed_contract {arg_ty = _; address = {destination; entrypoint}} = + wrap_error_lwt + @@ Script_ir_translator.parse_contract_data + ctxt + (-1) + Script_typed_ir.unit_t + (Destination.Sc_rollup rollup) + ~entrypoint:(Entrypoint.of_string_strict_exn "reset") + in + (* Check that the destinations match. *) + let* () = + Assert.equal_string + ~loc:__LOC__ + (Destination.to_b58check destination) + rollup_destination + in + (* Check that entrypoints match. *) + let* () = + Assert.equal_string ~loc:__LOC__ (Entrypoint.to_string entrypoint) "reset" + in + return () + +(** Test that [parse_contract_data] for rollup with invalid type fails. *) +let test_parse_contract_data_for_rollup_with_invalid_type () = + let open Lwt_result_syntax in + let* block, (contract, _) = context_init_with_sc_rollup_enabled T2 in + let* block, rollup = sc_originate block contract "string" in + let* incr = Incremental.begin_construction block in + let ctxt = Incremental.alpha_ctxt incr in + let entrypoint = Entrypoint.of_string_strict_exn "add" in + let*! res = + wrap_error_lwt + @@ Script_ir_translator.parse_contract_data + ctxt + (-1) + Script_typed_ir.unit_t + (Destination.Sc_rollup rollup) + ~entrypoint + in + Assert.proto_error + ~loc:__LOC__ + res + (( = ) (Script_tc_errors.No_such_entrypoint entrypoint)) + let tests = [ Tztest.tztest "test unparse view" `Quick test_unparse_view; @@ -797,4 +934,16 @@ let tests = "test forbidden CREATE_CONTRACT in view" `Quick (test_forbidden_op_in_view "CREATE_CONTRACT"); + Tztest.tztest + "test parse contract data for rollup" + `Quick + test_parse_contract_data_for_unit_rollup; + Tztest.tztest + "test parse contract data for rollup with entrypoint" + `Quick + test_parse_contract_data_for_rollup_with_entrypoints; + Tztest.tztest + "test parse contract data for rollup with entrypoint" + `Quick + test_parse_contract_data_for_rollup_with_invalid_type; ] -- GitLab