From deb9a5b8ead4d40adf22a0da5ade6e5a86973b12 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 9 Jan 2021 19:55:18 +0100 Subject: [PATCH] Storage: rename functions Use the following convention: - 'add` for functional updates (with 't' first) - 'set' for side-effect updates (e.g. returning unit) - 'find' for getters which might return an option --- src/lib_protocol_environment/shell_context.ml | 16 ++++- src/lib_shell/block_directory.ml | 4 +- src/lib_shell/patch_context.ml | 2 +- src/lib_shell/prevalidation.ml | 4 +- src/lib_shell_benchmarks/io_helpers.ml | 4 +- src/lib_storage/context.ml | 62 ++++++++--------- src/lib_storage/context.mli | 38 +++++++---- src/lib_storage/test/test_context.ml | 68 +++++++++---------- src/lib_validation/block_validation.ml | 37 +++++----- .../lib_delegate/client_baking_forge.ml | 3 +- .../lib_delegate/client_baking_forge.ml | 7 +- .../lib_delegate/client_baking_forge.ml | 7 +- 12 files changed, 137 insertions(+), 115 deletions(-) diff --git a/src/lib_protocol_environment/shell_context.ml b/src/lib_protocol_environment/shell_context.ml index e211f3c8c8ca..71a76128a4a0 100644 --- a/src/lib_protocol_environment/shell_context.ml +++ b/src/lib_protocol_environment/shell_context.ml @@ -30,7 +30,21 @@ let ( >>= ) = Lwt.( >>= ) type _ Context.kind += Shell : Tezos_storage.Context.t Context.kind -let ops = (module Tezos_storage.Context : CONTEXT with type t = 'ctxt) +module C = struct + include Tezos_storage.Context + + let set = add + + let get = find + + let dir_mem = mem_tree + + let remove_rec = remove + + let set_protocol = add_protocol +end + +let ops = (module C : CONTEXT with type t = 'ctxt) let checkout index context_hash = Tezos_storage.Context.checkout index context_hash diff --git a/src/lib_shell/block_directory.ml b/src/lib_shell/block_directory.ml index 5356a4409432..82b6fa3ea582 100644 --- a/src/lib_shell/block_directory.ml +++ b/src/lib_shell/block_directory.ml @@ -28,7 +28,7 @@ let rec read_partial_context context path depth = if depth = 0 then Lwt.return Block_services.Cut else (* try to read as file *) - Context.get context path + Context.find context path >>= function | Some v -> Lwt.return (Block_services.Key v) @@ -297,7 +297,7 @@ let build_raw_rpc_directory ~user_activated_upgrades >>=? fun context -> Context.mem context path >>= fun mem -> - Context.dir_mem context path + Context.mem_tree context path >>= fun dir_mem -> if not (mem || dir_mem) then Lwt.fail Not_found else read_partial_context context path depth >>= fun dir -> return dir) ; diff --git a/src/lib_shell/patch_context.ml b/src/lib_shell/patch_context.ml index fe997b5fa4ab..d4e9e5f580ca 100644 --- a/src/lib_shell/patch_context.ml +++ b/src/lib_shell/patch_context.ml @@ -29,7 +29,7 @@ let patch_context (genesis : Genesis.t) key_json ctxt = | None -> Lwt.return ctxt | Some (key, json) -> - Tezos_storage.Context.set + Tezos_storage.Context.add ctxt [key] (Data_encoding.Binary.to_bytes_exn Data_encoding.json json) ) diff --git a/src/lib_shell/prevalidation.ml b/src/lib_shell/prevalidation.ml index 2ad2aae7c00c..2cb88990107e 100644 --- a/src/lib_shell/prevalidation.ml +++ b/src/lib_shell/prevalidation.ml @@ -403,7 +403,7 @@ let preapply ~user_activated_upgrades ~user_activated_protocol_overrides environment V1, they contain no operations. *) return context | Some hash -> - Context.set_predecessor_ops_metadata_hash context hash + Context.add_predecessor_ops_metadata_hash context hash >|= ok) >>=? fun context -> State.Block.metadata_hash predecessor @@ -412,7 +412,7 @@ let preapply ~user_activated_upgrades ~user_activated_protocol_overrides (* Block metadata hash should always be set in environment V1. *) fail @@ Missing_block_metadata_hash pred_block_hash | Some predecessor_block_metadata_hash -> - Context.set_predecessor_block_metadata_hash + Context.add_predecessor_block_metadata_hash context predecessor_block_metadata_hash >|= ok )) diff --git a/src/lib_shell_benchmarks/io_helpers.ml b/src/lib_shell_benchmarks/io_helpers.ml index c1cf02fd2e2e..e94760f90c21 100644 --- a/src/lib_shell_benchmarks/io_helpers.ml +++ b/src/lib_shell_benchmarks/io_helpers.ml @@ -117,7 +117,7 @@ let initialize_context_with_fan_out rng_state context fan_out depth (fun ctxt key -> let path = path @ [key] in let bytes = Base_samplers.uniform_bytes rng_state ~nbytes:8 in - Tezos_storage.Context.set ctxt path bytes >>= fun ctxt -> return ctxt) + Tezos_storage.Context.add ctxt path bytes >>= return) context keys >>=? fun context -> return (List.hd keys |> Option.get, context) @@ -125,7 +125,7 @@ let initialize_context_with_fan_out rng_state context fan_out depth let rec loop context path depth = if depth = 0 then let bytes = Base_samplers.uniform_bytes rng_state ~nbytes:storage_size in - Tezos_storage.Context.set context path bytes + Tezos_storage.Context.add context path bytes >>= fun context -> return (context, path) else populate_dummy path fan_out diff --git a/src/lib_storage/context.ml b/src/lib_storage/context.ml index e7fe16d25605..a2238c0eed8f 100644 --- a/src/lib_storage/context.ml +++ b/src/lib_storage/context.ml @@ -371,24 +371,24 @@ type value = bytes let mem ctxt key = Store.Tree.mem ctxt.tree (data_key key) >>= fun v -> Lwt.return v -let dir_mem ctxt key = +let mem_tree ctxt key = Store.Tree.mem_tree ctxt.tree (data_key key) >>= fun v -> Lwt.return v -let raw_get ctxt key = +let raw_find ctxt key = Store.Tree.find ctxt.tree key >|= Option.map Bytes.of_string -let get t key = raw_get t (data_key key) +let find t key = raw_find t (data_key key) -let raw_set ctxt key data = +let raw_add ctxt key data = let data = Bytes.to_string data in Store.Tree.add ctxt.tree key data >>= fun tree -> Lwt.return {ctxt with tree} -let set t key data = raw_set t (data_key key) data +let add t key data = raw_add t (data_key key) data -let raw_del ctxt key = +let raw_remove ctxt key = Store.Tree.remove ctxt.tree key >>= fun tree -> Lwt.return {ctxt with tree} -let remove_rec ctxt key = +let remove ctxt key = Store.Tree.remove ctxt.tree (data_key key) >>= fun tree -> Lwt.return {ctxt with tree} @@ -422,19 +422,19 @@ let fold ctxt key ~init ~f = (*-- Predefined Fields -------------------------------------------------------*) let get_protocol v = - raw_get v current_protocol_key + raw_find v current_protocol_key >>= function | None -> assert false | Some data -> Lwt.return (Protocol_hash.of_bytes_exn data) -let set_protocol v key = +let add_protocol v key = let key = Protocol_hash.to_bytes key in - raw_set v current_protocol_key key + raw_add v current_protocol_key key let get_test_chain v = - raw_get v current_test_chain_key + raw_find v current_test_chain_key >>= function | None -> Lwt.fail (Failure "Unexpected error (Context.get_test_chain)") @@ -449,17 +449,17 @@ let get_test_chain v = | Ok r -> Lwt.return r ) -let set_test_chain v id = +let add_test_chain v id = let id = Data_encoding.Binary.to_bytes_exn Test_chain_status.encoding id in - raw_set v current_test_chain_key id + raw_add v current_test_chain_key id -let del_test_chain v = raw_del v current_test_chain_key +let remove_test_chain v = raw_remove v current_test_chain_key let fork_test_chain v ~protocol ~expiration = - set_test_chain v (Forking {protocol; expiration}) + add_test_chain v (Forking {protocol; expiration}) -let get_predecessor_block_metadata_hash v = - raw_get v current_predecessor_block_metadata_hash_key +let find_predecessor_block_metadata_hash v = + raw_find v current_predecessor_block_metadata_hash_key >>= function | None -> Lwt.return_none @@ -474,14 +474,14 @@ let get_predecessor_block_metadata_hash v = | Some r -> Lwt.return_some r ) -let set_predecessor_block_metadata_hash v hash = +let add_predecessor_block_metadata_hash v hash = let data = Data_encoding.Binary.to_bytes_exn Block_metadata_hash.encoding hash in - raw_set v current_predecessor_block_metadata_hash_key data + raw_add v current_predecessor_block_metadata_hash_key data -let get_predecessor_ops_metadata_hash v = - raw_get v current_predecessor_ops_metadata_hash_key +let find_predecessor_ops_metadata_hash v = + raw_find v current_predecessor_ops_metadata_hash_key >>= function | None -> Lwt.return_none @@ -498,13 +498,13 @@ let get_predecessor_ops_metadata_hash v = | Some r -> Lwt.return_some r ) -let set_predecessor_ops_metadata_hash v hash = +let add_predecessor_ops_metadata_hash v hash = let data = Data_encoding.Binary.to_bytes_exn Operation_metadata_list_list_hash.encoding hash in - raw_set v current_predecessor_ops_metadata_hash_key data + raw_add v current_predecessor_ops_metadata_hash_key data (*-- Initialisation ----------------------------------------------------------*) @@ -528,9 +528,9 @@ let commit_genesis index ~chain_id ~time ~protocol = | Some patch_context -> patch_context ctxt ) >>=? fun ctxt -> - set_protocol ctxt protocol + add_protocol ctxt protocol >>= fun ctxt -> - set_test_chain ctxt Not_running + add_test_chain ctxt Not_running >>= fun ctxt -> raw_commit ~time ~message:"Genesis" ctxt >>= fun commit -> @@ -989,9 +989,9 @@ let get_protocol_data_from_header index block_header = >>= fun protocol_hash -> get_test_chain context >>= fun test_chain_status -> - get_predecessor_block_metadata_hash context + find_predecessor_block_metadata_hash context >>= fun predecessor_block_metadata_hash -> - get_predecessor_ops_metadata_hash context + find_predecessor_ops_metadata_hash context >>= fun predecessor_ops_metadata_hash -> data_node_hash context >>= fun data_key -> @@ -1063,13 +1063,13 @@ let validate_context_hash_consistency_and_commit ~data_hash let parent = Store.of_private_commit index.repo commit in {index; tree = Store.Tree.empty; parents = [parent]} in - set_test_chain ctxt test_chain + add_test_chain ctxt test_chain >>= fun ctxt -> - set_protocol ctxt protocol_hash + add_protocol ctxt protocol_hash >>= fun ctxt -> ( match predecessor_block_metadata_hash with | Some predecessor_block_metadata_hash -> - set_predecessor_block_metadata_hash + add_predecessor_block_metadata_hash ctxt predecessor_block_metadata_hash | None -> @@ -1077,7 +1077,7 @@ let validate_context_hash_consistency_and_commit ~data_hash >>= fun ctxt -> ( match predecessor_ops_metadata_hash with | Some predecessor_ops_metadata_hash -> - set_predecessor_ops_metadata_hash ctxt predecessor_ops_metadata_hash + add_predecessor_ops_metadata_hash ctxt predecessor_ops_metadata_hash | None -> Lwt.return ctxt ) >>= fun ctxt -> diff --git a/src/lib_storage/context.mli b/src/lib_storage/context.mli index e6cfaa40994e..7378d84f0e22 100644 --- a/src/lib_storage/context.mli +++ b/src/lib_storage/context.mli @@ -67,20 +67,34 @@ val commit_test_chain_genesis : (** {2 Generic interface} *) -(** [key] indicates a path in a context. *) +(** The type for context keys. *) type key = string list +(** The type for context values. *) type value = bytes +(** [mem t k] is an Lwt promise that resolves to true iff [k] is bound + to a value in [t]. *) val mem : context -> key -> bool Lwt.t -val dir_mem : context -> key -> bool Lwt.t +(** [mem_tree t k] is like {!mem} but for trees. *) +val mem_tree : context -> key -> bool Lwt.t -val get : context -> key -> value option Lwt.t +(** [find t k] is an Lwt promise that resolves to [v] if [Some k] is + bound to the value [v] in [t] and [None] otherwise. *) +val find : context -> key -> value option Lwt.t -val set : context -> key -> value -> t Lwt.t +(** [add t k v] is an Lwt promise that resolves to [c] such that: -val remove_rec : context -> key -> t Lwt.t + - [k] is bound to [v] in [c]; + - and [c] is similar to [t] otherwise. *) +val add : context -> key -> value -> t Lwt.t + +(** [remove t k v] is an Lwt promise that resolves to [c] such that: + + - [k] is unbound in [c]; + - and [c] is similar to [t] otherwise. *) +val remove : context -> key -> t Lwt.t (** [copy] returns None if the [from] key is not bound *) val copy : context -> from:key -> to_:key -> context option Lwt.t @@ -120,13 +134,13 @@ val set_master : index -> Context_hash.t -> unit Lwt.t val get_protocol : context -> Protocol_hash.t Lwt.t -val set_protocol : context -> Protocol_hash.t -> context Lwt.t +val add_protocol : context -> Protocol_hash.t -> context Lwt.t val get_test_chain : context -> Test_chain_status.t Lwt.t -val set_test_chain : context -> Test_chain_status.t -> context Lwt.t +val add_test_chain : context -> Test_chain_status.t -> context Lwt.t -val del_test_chain : context -> context Lwt.t +val remove_test_chain : context -> context Lwt.t val fork_test_chain : context -> @@ -136,16 +150,16 @@ val fork_test_chain : val clear_test_chain : index -> Chain_id.t -> unit Lwt.t -val get_predecessor_block_metadata_hash : +val find_predecessor_block_metadata_hash : context -> Block_metadata_hash.t option Lwt.t -val set_predecessor_block_metadata_hash : +val add_predecessor_block_metadata_hash : context -> Block_metadata_hash.t -> context Lwt.t -val get_predecessor_ops_metadata_hash : +val find_predecessor_ops_metadata_hash : context -> Operation_metadata_list_list_hash.t option Lwt.t -val set_predecessor_ops_metadata_hash : +val add_predecessor_ops_metadata_hash : context -> Operation_metadata_list_list_hash.t -> context Lwt.t (** {2 Context dumping} *) diff --git a/src/lib_storage/test/test_context.ml b/src/lib_storage/test/test_context.ml index e2c9adfac79e..0b846d3b59de 100644 --- a/src/lib_storage/test/test_context.ml +++ b/src/lib_storage/test/test_context.ml @@ -70,11 +70,11 @@ let create_block2 idx genesis_commit = | None -> Assert.fail_msg "checkout genesis_block" | Some ctxt -> - set ctxt ["a"; "b"] (Bytes.of_string "Novembre") + add ctxt ["a"; "b"] (Bytes.of_string "Novembre") >>= fun ctxt -> - set ctxt ["a"; "c"] (Bytes.of_string "Juin") + add ctxt ["a"; "c"] (Bytes.of_string "Juin") >>= fun ctxt -> - set ctxt ["version"] (Bytes.of_string "0.0") >>= fun ctxt -> commit ctxt + add ctxt ["version"] (Bytes.of_string "0.0") >>= fun ctxt -> commit ctxt let block3a = Block_hash.of_hex_exn @@ -86,9 +86,9 @@ let create_block3a idx block2_commit = | None -> Assert.fail_msg "checkout block2" | Some ctxt -> - remove_rec ctxt ["a"; "b"] + remove ctxt ["a"; "b"] >>= fun ctxt -> - set ctxt ["a"; "d"] (Bytes.of_string "Mars") >>= fun ctxt -> commit ctxt + add ctxt ["a"; "d"] (Bytes.of_string "Mars") >>= fun ctxt -> commit ctxt let block3b = Block_hash.of_hex_exn @@ -104,9 +104,9 @@ let create_block3b idx block2_commit = | None -> Assert.fail_msg "checkout block3b" | Some ctxt -> - remove_rec ctxt ["a"; "c"] + remove ctxt ["a"; "c"] >>= fun ctxt -> - set ctxt ["a"; "d"] (Bytes.of_string "Février") + add ctxt ["a"; "d"] (Bytes.of_string "Février") >>= fun ctxt -> commit ctxt type t = { @@ -145,13 +145,13 @@ let test_simple {idx; block2; _} = | None -> Assert.fail_msg "checkout block2" | Some ctxt -> - get ctxt ["version"] + find ctxt ["version"] >>= fun version -> Assert.equal_string_option ~msg:__LOC__ (c version) (Some "0.0") ; - get ctxt ["a"; "b"] + find ctxt ["a"; "b"] >>= fun novembre -> Assert.equal_string_option (Some "Novembre") (c novembre) ; - get ctxt ["a"; "c"] + find ctxt ["a"; "c"] >>= fun juin -> Assert.equal_string_option ~msg:__LOC__ (Some "Juin") (c juin) ; Lwt.return_unit @@ -162,16 +162,16 @@ let test_continuation {idx; block3a; _} = | None -> Assert.fail_msg "checkout block3a" | Some ctxt -> - get ctxt ["version"] + find ctxt ["version"] >>= fun version -> Assert.equal_string_option ~msg:__LOC__ (Some "0.0") (c version) ; - get ctxt ["a"; "b"] + find ctxt ["a"; "b"] >>= fun novembre -> Assert.is_none ~msg:__LOC__ (c novembre) ; - get ctxt ["a"; "c"] + find ctxt ["a"; "c"] >>= fun juin -> Assert.equal_string_option ~msg:__LOC__ (Some "Juin") (c juin) ; - get ctxt ["a"; "d"] + find ctxt ["a"; "d"] >>= fun mars -> Assert.equal_string_option ~msg:__LOC__ (Some "Mars") (c mars) ; Lwt.return_unit @@ -182,16 +182,16 @@ let test_fork {idx; block3b; _} = | None -> Assert.fail_msg "checkout block3b" | Some ctxt -> - get ctxt ["version"] + find ctxt ["version"] >>= fun version -> Assert.equal_string_option ~msg:__LOC__ (Some "0.0") (c version) ; - get ctxt ["a"; "b"] + find ctxt ["a"; "b"] >>= fun novembre -> Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ; - get ctxt ["a"; "c"] + find ctxt ["a"; "c"] >>= fun juin -> Assert.is_none ~msg:__LOC__ (c juin) ; - get ctxt ["a"; "d"] + find ctxt ["a"; "d"] >>= fun mars -> Assert.equal_string_option ~msg:__LOC__ (Some "Février") (c mars) ; Lwt.return_unit @@ -202,31 +202,31 @@ let test_replay {idx; genesis; _} = | None -> Assert.fail_msg "checkout genesis_block" | Some ctxt0 -> - set ctxt0 ["version"] (Bytes.of_string "0.0") + add ctxt0 ["version"] (Bytes.of_string "0.0") >>= fun ctxt1 -> - set ctxt1 ["a"; "b"] (Bytes.of_string "Novembre") + add ctxt1 ["a"; "b"] (Bytes.of_string "Novembre") >>= fun ctxt2 -> - set ctxt2 ["a"; "c"] (Bytes.of_string "Juin") + add ctxt2 ["a"; "c"] (Bytes.of_string "Juin") >>= fun ctxt3 -> - set ctxt3 ["a"; "d"] (Bytes.of_string "July") + add ctxt3 ["a"; "d"] (Bytes.of_string "July") >>= fun ctxt4a -> - set ctxt3 ["a"; "d"] (Bytes.of_string "Juillet") + add ctxt3 ["a"; "d"] (Bytes.of_string "Juillet") >>= fun ctxt4b -> - set ctxt4a ["a"; "b"] (Bytes.of_string "November") + add ctxt4a ["a"; "b"] (Bytes.of_string "November") >>= fun ctxt5a -> - get ctxt4a ["a"; "b"] + find ctxt4a ["a"; "b"] >>= fun novembre -> Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ; - get ctxt5a ["a"; "b"] + find ctxt5a ["a"; "b"] >>= fun november -> Assert.equal_string_option ~msg:__LOC__ (Some "November") (c november) ; - get ctxt5a ["a"; "d"] + find ctxt5a ["a"; "d"] >>= fun july -> Assert.equal_string_option ~msg:__LOC__ (Some "July") (c july) ; - get ctxt4b ["a"; "b"] + find ctxt4b ["a"; "b"] >>= fun novembre -> Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ; - get ctxt4b ["a"; "d"] + find ctxt4b ["a"; "d"] >>= fun juillet -> Assert.equal_string_option ~msg:__LOC__ (Some "Juillet") (c juillet) ; Lwt.return_unit @@ -246,15 +246,15 @@ let test_fold {idx; genesis; _} = | None -> Assert.fail_msg "checkout genesis_block" | Some ctxt -> - set ctxt ["a"; "b"] (Bytes.of_string "Novembre") + add ctxt ["a"; "b"] (Bytes.of_string "Novembre") >>= fun ctxt -> - set ctxt ["a"; "c"] (Bytes.of_string "Juin") + add ctxt ["a"; "c"] (Bytes.of_string "Juin") >>= fun ctxt -> - set ctxt ["a"; "d"; "e"] (Bytes.of_string "Septembre") + add ctxt ["a"; "d"; "e"] (Bytes.of_string "Septembre") >>= fun ctxt -> - set ctxt ["f"] (Bytes.of_string "Avril") + add ctxt ["f"] (Bytes.of_string "Avril") >>= fun ctxt -> - set ctxt ["g"; "h"] (Bytes.of_string "Avril") + add ctxt ["g"; "h"] (Bytes.of_string "Avril") >>= fun ctxt -> keys ctxt [] >>= fun l -> diff --git a/src/lib_validation/block_validation.ml b/src/lib_validation/block_validation.ml index 7ff703922fdb..d3ed63866b10 100644 --- a/src/lib_validation/block_validation.ml +++ b/src/lib_validation/block_validation.ml @@ -63,17 +63,17 @@ let update_testchain_status ctxt predecessor_header timestamp = return ctxt | Running {expiration; _} -> if Time.Protocol.(expiration <= timestamp) then - Context.set_test_chain ctxt Not_running >>= fun ctxt -> return ctxt + Context.add_test_chain ctxt Not_running >>= return else return ctxt | Forking {protocol; expiration} -> let predecessor_hash = Block_header.hash predecessor_header in let genesis = Context.compute_testchain_genesis predecessor_hash in let chain_id = Chain_id.of_block_hash genesis in (* legacy semantics *) - Context.set_test_chain + Context.add_test_chain ctxt (Running {chain_id; genesis; protocol; expiration}) - >>= fun ctxt -> return ctxt + >>= return let is_testchain_forking ctxt = Context.get_test_chain ctxt @@ -96,12 +96,11 @@ let init_test_chain ctxt forked_header = Proto_test.init test_ctxt forked_header.Block_header.shell >>=? fun {context = test_ctxt; _} -> let test_ctxt = Shell_context.unwrap_disk_context test_ctxt in - Context.set_test_chain test_ctxt Not_running + Context.add_test_chain test_ctxt Not_running >>= fun test_ctxt -> - Context.set_protocol test_ctxt protocol + Context.add_protocol test_ctxt protocol >>= fun test_ctxt -> - Context.commit_test_chain_genesis test_ctxt forked_header - >>= fun genesis_header -> return genesis_header + Context.commit_test_chain_genesis test_ctxt forked_header >>= return let result_encoding = let open Data_encoding in @@ -150,13 +149,11 @@ let may_force_protocol_upgrade ~user_activated_upgrades ~level | None -> Lwt.return validation_result | Some hash -> - let context = - Shell_context.unwrap_disk_context validation_result.context - in - Context.set_protocol context hash - >>= fun context -> - let context = Shell_context.wrap_disk_context context in - Lwt.return {validation_result with context} + let ctxt = Shell_context.unwrap_disk_context validation_result.context in + Context.add_protocol ctxt hash + >|= fun ctxt -> + let context = Shell_context.wrap_disk_context ctxt in + {validation_result with context} (** Applies user activated updates based either on block level or on voted protocols *) @@ -177,10 +174,10 @@ let may_patch_protocol ~user_activated_upgrades ~level validation_result | Some replacement_protocol -> - Context.set_protocol context replacement_protocol - >>= fun context -> - let context = Shell_context.wrap_disk_context context in - Lwt.return {validation_result with context} + Context.add_protocol context replacement_protocol + >|= fun ctxt -> + let context = Shell_context.wrap_disk_context ctxt in + {validation_result with context} module Make (Proto : Registered_protocol.T) = struct let check_block_header ~(predecessor_block_header : Block_header.t) hash @@ -310,13 +307,13 @@ module Make (Proto : Registered_protocol.T) = struct | None -> Lwt.return context | Some hash -> - Context.set_predecessor_block_metadata_hash context hash ) + Context.add_predecessor_block_metadata_hash context hash ) >>= fun context -> ( match predecessor_ops_metadata_hash with | None -> Lwt.return context | Some hash -> - Context.set_predecessor_ops_metadata_hash context hash ) + Context.add_predecessor_ops_metadata_hash context hash ) >>= fun context -> let context = Shell_context.wrap_disk_context context in Proto.begin_application diff --git a/src/proto_007_PsDELPH1/lib_delegate/client_baking_forge.ml b/src/proto_007_PsDELPH1/lib_delegate/client_baking_forge.ml index 968ed41f60e5..74060931c20d 100644 --- a/src/proto_007_PsDELPH1/lib_delegate/client_baking_forge.ml +++ b/src/proto_007_PsDELPH1/lib_delegate/client_baking_forge.ml @@ -750,8 +750,7 @@ let finalize_block_header shell_header ~timestamp validation_result operations return context | Running {expiration; _} -> if Time.Protocol.(expiration <= timestamp) then - Context.set_test_chain context Not_running - >>= fun context -> return context + Context.add_test_chain context Not_running >>= return else return context | Forking _ -> fail Forking_test_chain) diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_forge.ml b/src/proto_008_PtEdoTez/lib_delegate/client_baking_forge.ml index 28aad1e5ba11..b379a6a373b0 100644 --- a/src/proto_008_PtEdoTez/lib_delegate/client_baking_forge.ml +++ b/src/proto_008_PtEdoTez/lib_delegate/client_baking_forge.ml @@ -746,15 +746,14 @@ let finalize_block_header shell_header ~timestamp validation_result operations return context | Running {expiration; _} -> if Time.Protocol.(expiration <= timestamp) then - Context.set_test_chain context Not_running - >>= fun context -> return context + Context.add_test_chain context Not_running >>= return else return context | Forking _ -> fail Forking_test_chain) >>=? fun context -> ( match predecessor_block_metadata_hash with | Some predecessor_block_metadata_hash -> - Context.set_predecessor_block_metadata_hash + Context.add_predecessor_block_metadata_hash context predecessor_block_metadata_hash | None -> @@ -762,7 +761,7 @@ let finalize_block_header shell_header ~timestamp validation_result operations >>= fun context -> ( match predecessor_ops_metadata_hash with | Some predecessor_ops_metadata_hash -> - Context.set_predecessor_ops_metadata_hash + Context.add_predecessor_ops_metadata_hash context predecessor_ops_metadata_hash | None -> diff --git a/src/proto_alpha/lib_delegate/client_baking_forge.ml b/src/proto_alpha/lib_delegate/client_baking_forge.ml index 6a01e168ba27..c18b7a717418 100644 --- a/src/proto_alpha/lib_delegate/client_baking_forge.ml +++ b/src/proto_alpha/lib_delegate/client_baking_forge.ml @@ -750,15 +750,14 @@ let finalize_block_header shell_header ~timestamp validation_result operations return context | Running {expiration; _} -> if Time.Protocol.(expiration <= timestamp) then - Context.set_test_chain context Not_running - >>= fun context -> return context + Context.add_test_chain context Not_running >>= return else return context | Forking _ -> fail Forking_test_chain) >>=? fun context -> ( match predecessor_block_metadata_hash with | Some predecessor_block_metadata_hash -> - Context.set_predecessor_block_metadata_hash + Context.add_predecessor_block_metadata_hash context predecessor_block_metadata_hash | None -> @@ -766,7 +765,7 @@ let finalize_block_header shell_header ~timestamp validation_result operations >>= fun context -> ( match predecessor_ops_metadata_hash with | Some predecessor_ops_metadata_hash -> - Context.set_predecessor_ops_metadata_hash + Context.add_predecessor_ops_metadata_hash context predecessor_ops_metadata_hash | None -> -- GitLab