From 8caafd6a61161cda306844e50048d90eb82fa8b8 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 9 May 2022 08:51:50 +0200 Subject: [PATCH 1/8] Proto/RPCs: contract_big_map_get accepts only originated contracts --- .../lib_client/client_proto_context.ml | 2 +- .../lib_protocol/contract_services.ml | 58 +++++++++++-------- .../lib_protocol/contract_services.mli | 2 +- 3 files changed, 35 insertions(+), 27 deletions(-) diff --git a/src/proto_alpha/lib_client/client_proto_context.ml b/src/proto_alpha/lib_client/client_proto_context.ml index f6cfdce58e67..c94e55b135ca 100644 --- a/src/proto_alpha/lib_client/client_proto_context.ml +++ b/src/proto_alpha/lib_client/client_proto_context.ml @@ -53,7 +53,7 @@ let get_contract_big_map_value (rpc : #rpc_context) ~chain ~block contract key = Alpha_services.Contract.contract_big_map_get_opt rpc (chain, block) - (Contract.Originated contract) + contract key let get_script (rpc : #rpc_context) ~chain ~block ~unparsing_mode diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index ee2a3a66a40e..2cb6f4c2a051 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -466,32 +466,39 @@ let[@coq_axiom_with_reason "gadt"] register () = ~chunked:true S.contract_big_map_get_opt (fun ctxt contract () (key, key_type) -> - Contract.get_script ctxt contract >>=? fun (ctxt, script) -> - let key_type_node = Micheline.root key_type in - Script_ir_translator.parse_comparable_ty ctxt key_type_node - >>?= fun (Ex_comparable_ty key_type, ctxt) -> - Script_ir_translator.parse_comparable_data - ctxt - key_type - (Micheline.root key) - >>=? fun (key, ctxt) -> - Script_ir_translator.hash_comparable_data ctxt key_type key - >>=? fun (key, ctxt) -> - match script with - | None -> return_none - | Some script -> ( - let ctxt = Gas.set_unlimited ctxt in - let open Script_ir_translator in - parse_script ctxt ~legacy:true ~allow_forged_in_storage:true script - >>=? fun (Ex_script (Script script), ctxt) -> - Script_ir_translator.collect_lazy_storage + match (contract : Contract.t) with + | Implicit _ -> return_none + | Originated _ -> ( + Contract.get_script ctxt contract >>=? fun (ctxt, script) -> + let key_type_node = Micheline.root key_type in + Script_ir_translator.parse_comparable_ty ctxt key_type_node + >>?= fun (Ex_comparable_ty key_type, ctxt) -> + Script_ir_translator.parse_comparable_data ctxt - script.storage_type - script.storage - >>?= fun (ids, _ctxt) -> - match Script_ir_translator.list_of_big_map_ids ids with - | [] | _ :: _ :: _ -> return_some None - | [id] -> do_big_map_get ctxt id key >|=? Option.some)) ; + key_type + (Micheline.root key) + >>=? fun (key, ctxt) -> + Script_ir_translator.hash_comparable_data ctxt key_type key + >>=? fun (key, ctxt) -> + match script with + | None -> return_none + | Some script -> ( + let ctxt = Gas.set_unlimited ctxt in + let open Script_ir_translator in + parse_script + ctxt + ~legacy:true + ~allow_forged_in_storage:true + script + >>=? fun (Ex_script (Script script), ctxt) -> + Script_ir_translator.collect_lazy_storage + ctxt + script.storage_type + script.storage + >>?= fun (ids, _ctxt) -> + match Script_ir_translator.list_of_big_map_ids ids with + | [] | _ :: _ :: _ -> return_some None + | [id] -> do_big_map_get ctxt id key >|=? Option.some))) ; opt_register2 ~chunked:true S.big_map_get (fun ctxt id key () () -> do_big_map_get ctxt id key) ; register1 ~chunked:true S.big_map_get_all (fun ctxt id {offset; length} () -> @@ -585,6 +592,7 @@ let big_map_get ctxt block id key = RPC_context.make_call2 S.big_map_get ctxt block id key () () let contract_big_map_get_opt ctxt block contract key = + let contract = Contract.Originated contract in RPC_context.make_call1 S.contract_big_map_get_opt ctxt block contract () key let single_sapling_get_diff ctxt block id ?offset_commitment ?offset_nullifier diff --git a/src/proto_alpha/lib_protocol/contract_services.mli b/src/proto_alpha/lib_protocol/contract_services.mli index 6230fb8c444b..45556541602c 100644 --- a/src/proto_alpha/lib_protocol/contract_services.mli +++ b/src/proto_alpha/lib_protocol/contract_services.mli @@ -126,7 +126,7 @@ val big_map_get : val contract_big_map_get_opt : 'a #RPC_context.simple -> 'a -> - Contract.t -> + Contract_hash.t -> Script.expr * Script.expr -> Script.expr option shell_tzresult Lwt.t -- GitLab From 2c8d49df6316379da70bc967b9d9b7ec065004bf Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 9 May 2022 10:02:32 +0200 Subject: [PATCH 2/8] Proto/RPCs: contract_single_sapling_get_diff accepts only originated contracts --- src/proto_alpha/lib_client_sapling/context.ml | 1 - src/proto_alpha/lib_protocol/contract_services.ml | 11 ++++++++--- src/proto_alpha/lib_protocol/contract_services.mli | 2 +- .../lib_protocol/test/helpers/sapling_helpers.ml | 2 +- .../test/integration/michelson/test_sapling.ml | 4 ++-- 5 files changed, 12 insertions(+), 8 deletions(-) diff --git a/src/proto_alpha/lib_client_sapling/context.ml b/src/proto_alpha/lib_client_sapling/context.ml index b7579a005ab0..9412ecb6f6e0 100644 --- a/src/proto_alpha/lib_client_sapling/context.ml +++ b/src/proto_alpha/lib_client_sapling/context.ml @@ -381,7 +381,6 @@ module Client_state = struct (** Call the node RPC to obtain the storage diff of a contract *) let get_diff cctxt contract offset_commitment offset_nullifier = - let contract = Protocol.Alpha_context.Contract.Originated contract in Protocol.Alpha_services.Contract.single_sapling_get_diff cctxt (cctxt#chain, cctxt#block) diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index 2cb6f4c2a051..d49539b049ad 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -269,8 +269,13 @@ module S = struct let service = RPC_service.get_service ~description ~query ~output path in ( service, fun ctxt contract_id q () -> - single_sapling_get_id ctxt contract_id >>=? fun (sapling_id, ctxt) -> - Option.map_es (fun sapling_id -> f ctxt sapling_id q) sapling_id ) + match (contract_id : Contract.t) with + | Implicit _ -> return_none + | Originated _ -> + single_sapling_get_id ctxt contract_id + >>=? fun (sapling_id, ctxt) -> + Option.map_es (fun sapling_id -> f ctxt sapling_id q) sapling_id + ) let get_diff = make_service Sapling_services.S.Args.get_diff @@ -600,5 +605,5 @@ let single_sapling_get_diff ctxt block id ?offset_commitment ?offset_nullifier S.Sapling.(mk_call1 get_diff) ctxt block - id + (Contract.Originated id) Sapling_services.{offset_commitment; offset_nullifier} diff --git a/src/proto_alpha/lib_protocol/contract_services.mli b/src/proto_alpha/lib_protocol/contract_services.mli index 45556541602c..f4bd3630d529 100644 --- a/src/proto_alpha/lib_protocol/contract_services.mli +++ b/src/proto_alpha/lib_protocol/contract_services.mli @@ -133,7 +133,7 @@ val contract_big_map_get_opt : val single_sapling_get_diff : 'a #RPC_context.simple -> 'a -> - Contract.t -> + Contract_hash.t -> ?offset_commitment:int64 -> ?offset_nullifier:int64 -> unit -> diff --git a/src/proto_alpha/lib_protocol/test/helpers/sapling_helpers.ml b/src/proto_alpha/lib_protocol/test/helpers/sapling_helpers.ml index 8742fd957b08..4d07ce051426 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/sapling_helpers.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/sapling_helpers.ml @@ -410,7 +410,7 @@ module Interpreter_helpers = struct Alpha_services.Contract.single_sapling_get_diff Block.rpc_ctxt block - (Alpha_context.Contract.Originated dst) + dst ~offset_commitment:0L ~offset_nullifier:0L () diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_sapling.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_sapling.ml index 312d4b8eaaa8..8d949e1d0087 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_sapling.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_sapling.ml @@ -903,7 +903,7 @@ module Interpreter_tests = struct Alpha_services.Contract.single_sapling_get_diff Block.rpc_ctxt block_1 - (Contract.Originated dst) + dst ~offset_commitment:0L ~offset_nullifier:0L () @@ -940,7 +940,7 @@ module Interpreter_tests = struct Alpha_services.Contract.single_sapling_get_diff Block.rpc_ctxt block_2 - (Contract.Originated dst) + dst ~offset_commitment:0L ~offset_nullifier:0L () -- GitLab From b7b4f36d709497e8bee4d8d5b19ba362343d5be2 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 9 May 2022 10:46:56 +0200 Subject: [PATCH 3/8] Proto/RPCs: list_entrypoints accepts only originated contracts --- .../lib_client/michelson_v1_entrypoints.ml | 2 +- .../lib_protocol/contract_services.ml | 74 ++++++++++--------- .../lib_protocol/contract_services.mli | 2 +- 3 files changed, 41 insertions(+), 37 deletions(-) diff --git a/src/proto_alpha/lib_client/michelson_v1_entrypoints.ml b/src/proto_alpha/lib_client/michelson_v1_entrypoints.ml index d98497739434..a13d760aaa72 100644 --- a/src/proto_alpha/lib_client/michelson_v1_entrypoints.ml +++ b/src/proto_alpha/lib_client/michelson_v1_entrypoints.ml @@ -111,7 +111,7 @@ let list_contract_unreachables_and_entrypoints cctxt ~chain ~block ~contract Alpha_services.Contract.list_entrypoints cctxt (chain, block) - (Contract.Originated contract) + contract ~normalize_types let list_contract_unreachables cctxt ~chain ~block ~contract = diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index d49539b049ad..58bac692fd8e 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -433,40 +433,44 @@ let[@coq_axiom_with_reason "gadt"] register () = ~chunked:true S.list_entrypoints (fun ctxt v {normalize_types} () -> - Contract.get_script_code ctxt v >>=? fun (_, expr) -> - match expr with - | None -> return_none - | Some expr -> - let ctxt = Gas.set_unlimited ctxt in - let legacy = true in - let open Script_ir_translator in - Script.force_decode_in_context - ~consume_deserialization_gas:When_needed - ctxt - expr - >>?= fun (expr, _) -> - parse_toplevel ctxt ~legacy expr >>=? fun ({arg_type; _}, ctxt) -> - Lwt.return - ( parse_parameter_ty_and_entrypoints ctxt ~legacy arg_type - >>? fun (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, _) - -> - let unreachable_entrypoint, map = - Script_ir_translator.list_entrypoints_uncarbonated - arg_type - entrypoints - in - Entrypoint.Map.fold_e - (fun entry (Ex_ty ty, original_type_expr) (acc, ctxt) -> - (if normalize_types then - unparse_ty ~loc:() ctxt ty >|? fun (ty_node, ctxt) -> - (Micheline.strip_locations ty_node, ctxt) - else ok (Micheline.strip_locations original_type_expr, ctxt)) - >|? fun (ty_expr, ctxt) -> - ((Entrypoint.to_string entry, ty_expr) :: acc, ctxt)) - map - ([], ctxt) - >|? fun (entrypoint_types, _ctxt) -> - Some (unreachable_entrypoint, entrypoint_types) )) ; + match (v : Contract.t) with + | Implicit _ -> return_none + | Originated _ -> ( + Contract.get_script_code ctxt v >>=? fun (_, expr) -> + match expr with + | None -> return_none + | Some expr -> + let ctxt = Gas.set_unlimited ctxt in + let legacy = true in + let open Script_ir_translator in + Script.force_decode_in_context + ~consume_deserialization_gas:When_needed + ctxt + expr + >>?= fun (expr, _) -> + parse_toplevel ctxt ~legacy expr >>=? fun ({arg_type; _}, ctxt) -> + Lwt.return + ( parse_parameter_ty_and_entrypoints ctxt ~legacy arg_type + >>? fun ( Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, + _ ) -> + let unreachable_entrypoint, map = + Script_ir_translator.list_entrypoints_uncarbonated + arg_type + entrypoints + in + Entrypoint.Map.fold_e + (fun entry (Ex_ty ty, original_type_expr) (acc, ctxt) -> + (if normalize_types then + unparse_ty ~loc:() ctxt ty >|? fun (ty_node, ctxt) -> + (Micheline.strip_locations ty_node, ctxt) + else + ok (Micheline.strip_locations original_type_expr, ctxt)) + >|? fun (ty_expr, ctxt) -> + ((Entrypoint.to_string entry, ty_expr) :: acc, ctxt)) + map + ([], ctxt) + >|? fun (entrypoint_types, _ctxt) -> + Some (unreachable_entrypoint, entrypoint_types) ))) ; opt_register1 ~chunked:true S.contract_big_map_get_opt @@ -586,7 +590,7 @@ let list_entrypoints ctxt block contract ~normalize_types = S.list_entrypoints ctxt block - contract + (Contract.Originated contract) {normalize_types} () diff --git a/src/proto_alpha/lib_protocol/contract_services.mli b/src/proto_alpha/lib_protocol/contract_services.mli index f4bd3630d529..57e4de2af836 100644 --- a/src/proto_alpha/lib_protocol/contract_services.mli +++ b/src/proto_alpha/lib_protocol/contract_services.mli @@ -104,7 +104,7 @@ val entrypoint_type : val list_entrypoints : 'a #RPC_context.simple -> 'a -> - Contract.t -> + Contract_hash.t -> normalize_types:bool -> (Michelson_v1_primitives.prim list list * (string * Script.expr) list) shell_tzresult -- GitLab From 625a6242080a02e32f4d03cc30d7004cfbcd9090 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 9 May 2022 10:58:42 +0200 Subject: [PATCH 4/8] Proto/RPCs: entrypoint_type accepts only originated contracts --- .../lib_client/michelson_v1_entrypoints.ml | 2 +- .../lib_protocol/contract_services.ml | 68 ++++++++++--------- .../lib_protocol/contract_services.mli | 2 +- 3 files changed, 38 insertions(+), 34 deletions(-) diff --git a/src/proto_alpha/lib_client/michelson_v1_entrypoints.ml b/src/proto_alpha/lib_client/michelson_v1_entrypoints.ml index a13d760aaa72..08f8c0dd060f 100644 --- a/src/proto_alpha/lib_client/michelson_v1_entrypoints.ml +++ b/src/proto_alpha/lib_client/michelson_v1_entrypoints.ml @@ -66,7 +66,7 @@ let contract_entrypoint_type cctxt ~(chain : Chain_services.chain) ~block Alpha_services.Contract.entrypoint_type cctxt (chain, block) - (Contract.Originated contract) + contract entrypoint ~normalize_types >>= function diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index 58bac692fd8e..d8d0d3d4a45f 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -398,37 +398,41 @@ let[@coq_axiom_with_reason "gadt"] register () = ~chunked:true S.entrypoint_type (fun ctxt v entrypoint {normalize_types} () -> - Contract.get_script_code ctxt v >>=? fun (_, expr) -> - match expr with - | None -> return_none - | Some expr -> - let ctxt = Gas.set_unlimited ctxt in - let legacy = true in - let open Script_ir_translator in - Script.force_decode_in_context - ~consume_deserialization_gas:When_needed - ctxt - expr - >>?= fun (expr, _) -> - parse_toplevel ctxt ~legacy expr >>=? fun ({arg_type; _}, ctxt) -> - Lwt.return - ( parse_parameter_ty_and_entrypoints ctxt ~legacy arg_type - >>? fun (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, _) - -> - Gas_monad.run ctxt - @@ Script_ir_translator.find_entrypoint - ~error_details:(Informative ()) - arg_type - entrypoints - entrypoint - >>? fun (r, ctxt) -> - r |> function - | Ok (Ex_ty_cstr {ty; original_type_expr; _}) -> - if normalize_types then - unparse_ty ~loc:() ctxt ty >|? fun (ty_node, _ctxt) -> - Some (Micheline.strip_locations ty_node) - else ok (Some (Micheline.strip_locations original_type_expr)) - | Error _ -> Result.return_none )) ; + match (v : Contract.t) with + | Implicit _ -> return_none + | Originated _ -> ( + Contract.get_script_code ctxt v >>=? fun (_, expr) -> + match expr with + | None -> return_none + | Some expr -> + let ctxt = Gas.set_unlimited ctxt in + let legacy = true in + let open Script_ir_translator in + Script.force_decode_in_context + ~consume_deserialization_gas:When_needed + ctxt + expr + >>?= fun (expr, _) -> + parse_toplevel ctxt ~legacy expr >>=? fun ({arg_type; _}, ctxt) -> + Lwt.return + ( parse_parameter_ty_and_entrypoints ctxt ~legacy arg_type + >>? fun ( Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, + _ ) -> + Gas_monad.run ctxt + @@ Script_ir_translator.find_entrypoint + ~error_details:(Informative ()) + arg_type + entrypoints + entrypoint + >>? fun (r, ctxt) -> + r |> function + | Ok (Ex_ty_cstr {ty; original_type_expr; _}) -> + if normalize_types then + unparse_ty ~loc:() ctxt ty >|? fun (ty_node, _ctxt) -> + Some (Micheline.strip_locations ty_node) + else + ok (Some (Micheline.strip_locations original_type_expr)) + | Error _ -> Result.return_none ))) ; opt_register1 ~chunked:true S.list_entrypoints @@ -580,7 +584,7 @@ let entrypoint_type ctxt block contract entrypoint ~normalize_types = S.entrypoint_type ctxt block - contract + (Contract.Originated contract) entrypoint {normalize_types} () diff --git a/src/proto_alpha/lib_protocol/contract_services.mli b/src/proto_alpha/lib_protocol/contract_services.mli index 57e4de2af836..09d5e0f6508c 100644 --- a/src/proto_alpha/lib_protocol/contract_services.mli +++ b/src/proto_alpha/lib_protocol/contract_services.mli @@ -96,7 +96,7 @@ val storage : val entrypoint_type : 'a #RPC_context.simple -> 'a -> - Contract.t -> + Contract_hash.t -> Entrypoint.t -> normalize_types:bool -> Script.expr shell_tzresult Lwt.t -- GitLab From 043fe12f12f22f335fd52f1a7e291ba9a8123f0e Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 9 May 2022 18:13:43 +0200 Subject: [PATCH 5/8] Proto/Contract_services: generalize register_field helpers --- .../lib_protocol/contract_services.ml | 32 +++++++++++++------ 1 file changed, 23 insertions(+), 9 deletions(-) diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index d8d0d3d4a45f..fa2f88f7e958 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -293,23 +293,37 @@ end let[@coq_axiom_with_reason "gadt"] register () = let open Services_registration in register0 ~chunked:true S.list (fun ctxt () () -> Contract.list ctxt >|= ok) ; - let register_field ~chunked s f = + let register_field_gen ~filter_contract ~wrap_result ~chunked s f = opt_register1 ~chunked s (fun ctxt contract () () -> + filter_contract contract @@ fun () -> Contract.exists ctxt contract >>= function - | true -> f ctxt contract >|=? Option.some + | true -> f ctxt contract |> wrap_result | false -> return_none) in - let register_field_with_query ~chunked s f = + let register_field_with_query_gen ~filter_contract ~wrap_result ~chunked s f = opt_register1 ~chunked s (fun ctxt contract query () -> + filter_contract contract @@ fun () -> Contract.exists ctxt contract >>= function - | true -> f ctxt contract query >|=? Option.some + | true -> f ctxt contract query |> wrap_result | false -> return_none) in - let register_opt_field ~chunked s f = - opt_register1 ~chunked s (fun ctxt contract () () -> - Contract.exists ctxt contract >>= function - | true -> f ctxt contract - | false -> return_none) + let register_field s = + register_field_gen + ~filter_contract:(fun _c k -> k ()) + ~wrap_result:(fun res -> res >|=? Option.some) + s + in + let register_field_with_query s = + register_field_with_query_gen + ~filter_contract:(fun _c k -> k ()) + ~wrap_result:(fun res -> res >|=? Option.some) + s + in + let register_opt_field s = + register_field_gen + ~filter_contract:(fun _c k -> k ()) + ~wrap_result:(fun res -> res) + s in let do_big_map_get ctxt id key = let open Script_ir_translator in -- GitLab From 3abf0fbf8a5c1774fedfb470fbf7a8c9e1e9cdca Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 9 May 2022 18:30:57 +0200 Subject: [PATCH 6/8] Proto/RPCs: Contract.script work on originated contracts only --- src/proto_alpha/lib_client/client_proto_context.ml | 1 - src/proto_alpha/lib_protocol/contract_services.ml | 13 ++++++++++++- src/proto_alpha/lib_protocol/contract_services.mli | 7 +++++-- .../lib_protocol/test/helpers/context.ml | 1 - .../test/integration/michelson/test_sapling.ml | 1 - 5 files changed, 17 insertions(+), 6 deletions(-) diff --git a/src/proto_alpha/lib_client/client_proto_context.ml b/src/proto_alpha/lib_client/client_proto_context.ml index c94e55b135ca..fd8a161c13cd 100644 --- a/src/proto_alpha/lib_client/client_proto_context.ml +++ b/src/proto_alpha/lib_client/client_proto_context.ml @@ -66,7 +66,6 @@ let get_script (rpc : #rpc_context) ~chain ~block ~unparsing_mode ~contract let get_script_hash (rpc : #rpc_context) ~chain ~block contract = - let contract = Contract.Originated contract in Alpha_services.Contract.script_opt rpc (chain, block) contract >>=? fun script_opt -> Lwt.return @@ Environment.wrap_tzresult diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index fa2f88f7e958..85991c9984e6 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -325,6 +325,15 @@ let[@coq_axiom_with_reason "gadt"] register () = ~wrap_result:(fun res -> res) s in + let register_originated_opt_field s = + register_field_gen + ~filter_contract:(fun c k -> + match (c : Contract.t) with + | Implicit _ -> return_none + | Originated _ -> k ()) + ~wrap_result:(fun res -> res) + s + in let do_big_map_get ctxt id key = let open Script_ir_translator in let ctxt = Gas.set_unlimited ctxt in @@ -395,7 +404,7 @@ let[@coq_axiom_with_reason "gadt"] register () = | Originated _ -> return_none | Implicit mgr -> Contract.get_counter ctxt mgr >|=? fun counter -> Some counter) ; - register_opt_field ~chunked:true S.script (fun c v -> + register_originated_opt_field ~chunked:true S.script (fun c v -> Contract.get_script c v >|=? fun (_, v) -> v) ; register_opt_field ~chunked:true S.storage (fun ctxt contract -> Contract.get_script ctxt contract >>=? fun (ctxt, script) -> @@ -585,9 +594,11 @@ let counter ctxt block mgr = RPC_context.make_call1 S.counter ctxt block (Contract.Implicit mgr) () () let script ctxt block contract = + let contract = Contract.Originated contract in RPC_context.make_call1 S.script ctxt block contract () () let script_opt ctxt block contract = + let contract = Contract.Originated contract in RPC_context.make_opt_call1 S.script ctxt block contract () () let storage ctxt block contract = diff --git a/src/proto_alpha/lib_protocol/contract_services.mli b/src/proto_alpha/lib_protocol/contract_services.mli index 09d5e0f6508c..463a9466877f 100644 --- a/src/proto_alpha/lib_protocol/contract_services.mli +++ b/src/proto_alpha/lib_protocol/contract_services.mli @@ -82,12 +82,15 @@ val counter : counter shell_tzresult Lwt.t val script : - 'a #RPC_context.simple -> 'a -> Contract.t -> Script.t shell_tzresult Lwt.t + 'a #RPC_context.simple -> + 'a -> + Contract_hash.t -> + Script.t shell_tzresult Lwt.t val script_opt : 'a #RPC_context.simple -> 'a -> - Contract.t -> + Contract_hash.t -> Script.t option shell_tzresult Lwt.t val storage : diff --git a/src/proto_alpha/lib_protocol/test/helpers/context.ml b/src/proto_alpha/lib_protocol/test/helpers/context.ml index 83a69d9fb91b..cf43c9e7258d 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/context.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/context.ml @@ -305,7 +305,6 @@ module Contract = struct Alpha_services.Contract.storage rpc_ctxt ctxt contract let script ctxt contract = - let contract = Contract.Originated contract in Alpha_services.Contract.script rpc_ctxt ctxt contract >>=? fun {code; storage = _} -> match Data_encoding.force_decode code with diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_sapling.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_sapling.ml index 8d949e1d0087..f29f1e3c66a6 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_sapling.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_sapling.ml @@ -950,7 +950,6 @@ module Interpreter_tests = struct let is_root_in block dst root = Incremental.begin_construction block >>=? fun incr -> let ctx_2 = Incremental.alpha_ctxt incr in - let dst = Contract.Originated dst in Alpha_services.Contract.script Block.rpc_ctxt block dst >>=? fun script -> let ctx_without_gas_2 = Alpha_context.Gas.set_unlimited ctx_2 in Script_ir_translator.parse_script -- GitLab From e8db9cecaa1ddbfc725c14e4b93fb5877b75788d Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 9 May 2022 19:21:53 +0200 Subject: [PATCH 7/8] Proto/RPCs: Contract.storage work on originated contracts only --- src/proto_alpha/lib_protocol/contract_services.ml | 4 +++- src/proto_alpha/lib_protocol/contract_services.mli | 7 +++++-- src/proto_alpha/lib_protocol/test/helpers/context.ml | 1 - .../test/integration/michelson/test_sapling.ml | 6 +++--- 4 files changed, 11 insertions(+), 7 deletions(-) diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index 85991c9984e6..451152673e87 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -406,7 +406,7 @@ let[@coq_axiom_with_reason "gadt"] register () = Contract.get_counter ctxt mgr >|=? fun counter -> Some counter) ; register_originated_opt_field ~chunked:true S.script (fun c v -> Contract.get_script c v >|=? fun (_, v) -> v) ; - register_opt_field ~chunked:true S.storage (fun ctxt contract -> + register_originated_opt_field ~chunked:true S.storage (fun ctxt contract -> Contract.get_script ctxt contract >>=? fun (ctxt, script) -> match script with | None -> return_none @@ -602,6 +602,7 @@ let script_opt ctxt block contract = RPC_context.make_opt_call1 S.script ctxt block contract () () let storage ctxt block contract = + let contract = Contract.Originated contract in RPC_context.make_call1 S.storage ctxt block contract () () let entrypoint_type ctxt block contract entrypoint ~normalize_types = @@ -624,6 +625,7 @@ let list_entrypoints ctxt block contract ~normalize_types = () let storage_opt ctxt block contract = + let contract = Contract.Originated contract in RPC_context.make_opt_call1 S.storage ctxt block contract () () let big_map_get ctxt block id key = diff --git a/src/proto_alpha/lib_protocol/contract_services.mli b/src/proto_alpha/lib_protocol/contract_services.mli index 463a9466877f..e37d2ce837f6 100644 --- a/src/proto_alpha/lib_protocol/contract_services.mli +++ b/src/proto_alpha/lib_protocol/contract_services.mli @@ -94,7 +94,10 @@ val script_opt : Script.t option shell_tzresult Lwt.t val storage : - 'a #RPC_context.simple -> 'a -> Contract.t -> Script.expr shell_tzresult Lwt.t + 'a #RPC_context.simple -> + 'a -> + Contract_hash.t -> + Script.expr shell_tzresult Lwt.t val entrypoint_type : 'a #RPC_context.simple -> @@ -116,7 +119,7 @@ val list_entrypoints : val storage_opt : 'a #RPC_context.simple -> 'a -> - Contract.t -> + Contract_hash.t -> Script.expr option shell_tzresult Lwt.t val big_map_get : diff --git a/src/proto_alpha/lib_protocol/test/helpers/context.ml b/src/proto_alpha/lib_protocol/test/helpers/context.ml index cf43c9e7258d..245918e388de 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/context.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/context.ml @@ -301,7 +301,6 @@ module Contract = struct Alpha_services.Contract.delegate_opt rpc_ctxt ctxt contract let storage ctxt contract = - let contract = Contract.Originated contract in Alpha_services.Contract.storage rpc_ctxt ctxt contract let script ctxt contract = diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_sapling.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_sapling.ml index f29f1e3c66a6..8607ad55f501 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_sapling.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_sapling.ml @@ -1053,13 +1053,13 @@ module Interpreter_tests = struct Alpha_context.Script.(lazy_expr (Expr.from_string str_2)) in let fee = Test_tez.of_int 10 in - let dst = Contract.Originated dst in + let cdst = Contract.Originated dst in Op.transaction ~gas_limit:Max ~fee (B b) src - dst + cdst Tez.zero ~parameters:parameters_1 >>=? fun operation -> @@ -1069,7 +1069,7 @@ module Interpreter_tests = struct ~fee (B b) src - dst + cdst Tez.zero ~parameters:parameters_2 >>=? fun operation -> -- GitLab From e9006a846a55af33f026a60abac394f84bd4981f Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Fri, 10 Jun 2022 17:27:12 +0200 Subject: [PATCH 8/8] Proto/changelog: add entry --- docs/protocols/alpha.rst | 3 +++ 1 file changed, 3 insertions(+) diff --git a/docs/protocols/alpha.rst b/docs/protocols/alpha.rst index 7c12d6ef9e8b..e549a4be27c3 100644 --- a/docs/protocols/alpha.rst +++ b/docs/protocols/alpha.rst @@ -43,6 +43,9 @@ RPC Changes - Deprecate the ``endorsing_rights`` RPC for whole cycles, by deprecating the ``cycle`` parameter. (:gl:`!5082`) +- Some contract RPCs working on originated contracts only may return a different + error than before on implicit accounts. (MR :gl:`!5373`) + Bug Fixes --------- -- GitLab