From a95b51c1797c790a6a4bb9aeb2d4a71c33d9b809 Mon Sep 17 00:00:00 2001 From: Victor Allombert Date: Thu, 29 Sep 2022 16:19:24 +0200 Subject: [PATCH 1/4] Store/Consistency: improve protocol levels consistency check --- src/lib_shell_services/store_errors.ml | 16 ++++++ src/lib_store/unix/consistency.ml | 69 ++++++++++++++++---------- 2 files changed, 58 insertions(+), 27 deletions(-) diff --git a/src/lib_shell_services/store_errors.ml b/src/lib_shell_services/store_errors.ml index ab03160ed76e..e839d376e49a 100644 --- a/src/lib_shell_services/store_errors.ml +++ b/src/lib_shell_services/store_errors.ml @@ -962,6 +962,7 @@ type error += block : Block_hash.t; protocol : Protocol_hash.t; } + | Unexpected_missing_protocol of {protocol_level : int} | Inconsistent_genesis of {expected : Block_hash.t; got : Block_hash.t} | Inconsistent_cementing_highwatermark of { highest_cemented_level : Int32.t; @@ -1031,6 +1032,21 @@ let () = | _ -> None) (fun (block, protocol) -> Unexpected_missing_activation_block {block; protocol}) ; + register_error_kind + `Permanent + ~id:"store.unexpected_missing_protocol" + ~title:"Unexpected missing protocol" + ~description:"A protocol is unexpectedly missing from the store." + ~pp:(fun ppf protocol_level -> + Format.fprintf + ppf + "The protocol %d is unexpectedly missing from the store." + protocol_level) + Data_encoding.(obj1 (req "protocol_level" int31)) + (function + | Unexpected_missing_protocol {protocol_level} -> Some protocol_level + | _ -> None) + (fun protocol_level -> Unexpected_missing_protocol {protocol_level}) ; register_error_kind `Permanent ~id:"store.inconsistent_genesis" diff --git a/src/lib_store/unix/consistency.ml b/src/lib_store/unix/consistency.ml index e52cdc1a620d..b9e24af42675 100644 --- a/src/lib_store/unix/consistency.ml +++ b/src/lib_store/unix/consistency.ml @@ -90,34 +90,43 @@ let is_block_stored block_store (descriptor, expected_metadata, block_name) = | Some _ -> return_unit else return_unit -let check_protocol_levels block_store ~caboose protocol_levels = +(* Checks that the activation blocks above the caboose can be read and + that the caboose, savepoint and checkpoint have a protocol + associtated to them. *) +let check_protocol_levels block_store ~savepoint ~current_head protocol_levels = let open Lwt_result_syntax in - Protocol_levels.iter_es - (fun proto_level - {Protocol_levels.block = hash, activation_level; protocol; _} -> - if Compare.Int32.(activation_level < snd caboose) then - (* Cannot say anything *) - return_unit - else if (* Do not check the fake protocol *) - proto_level = 0 then return_unit - else - let* o = - let*! r = - Block_store.read_block - ~read_metadata:false - block_store - (Block (hash, 0)) - in - match r with - | Error _ -> return_none - | Ok block_opt -> return block_opt - in - match o with - | Some _ -> return_unit + let* savepoint = + Block_store.read_block + ~read_metadata:false + block_store + (Block (fst savepoint, 0)) + in + let* current_head = + Block_store.read_block + ~read_metadata:false + block_store + (Block (fst current_head, 0)) + in + (* We already checked that those blocks are present, it is safe to + unopt them. *) + let savepoint = WithExceptions.Option.get ~loc:__LOC__ savepoint in + let current_head = WithExceptions.Option.get ~loc:__LOC__ current_head in + let savepoint_proto_level = Block_repr.proto_level savepoint in + let current_head_proto_level = Block_repr.proto_level current_head in + let available_proto_levels = + savepoint_proto_level -- current_head_proto_level + in + let* () = + List.iter_es + (fun protocol_level -> + match Protocol_levels.find protocol_level protocol_levels with | None -> - tzfail - (Unexpected_missing_activation_block {block = hash; protocol})) - protocol_levels + (* We don't have it, we should... *) + tzfail (Unexpected_missing_protocol {protocol_level}) + | Some _ -> return_unit) + available_proto_levels + in + return_unit let check_invariant ~genesis ~caboose ~savepoint ~cementing_highwatermark ~checkpoint ~current_head ~alternate_heads = @@ -221,7 +230,13 @@ let check_consistency chain_dir genesis = check_cementing_highwatermark ~cementing_highwatermark block_store in let*! protocol_levels = Stored_data.get protocol_levels_data in - let* () = check_protocol_levels block_store ~caboose protocol_levels in + let* () = + check_protocol_levels + block_store + ~savepoint + ~current_head + protocol_levels + in let* () = check_invariant ~genesis:genesis_descr -- GitLab From 37503699e86e34c5befbc1b8c265a0cb72951598 Mon Sep 17 00:00:00 2001 From: Victor Allombert Date: Thu, 29 Sep 2022 16:13:41 +0200 Subject: [PATCH 2/4] Store/Consistency: rework restore consistency of protocol levels --- src/lib_shell_services/store_errors.ml | 17 +- src/lib_store/shared/store_events.ml | 19 +- src/lib_store/unix/cemented_block_store.ml | 81 ++- src/lib_store/unix/cemented_block_store.mli | 10 +- src/lib_store/unix/consistency.ml | 652 ++++++++++---------- 5 files changed, 380 insertions(+), 399 deletions(-) diff --git a/src/lib_shell_services/store_errors.ml b/src/lib_shell_services/store_errors.ml index e839d376e49a..3596afd60b97 100644 --- a/src/lib_shell_services/store_errors.ml +++ b/src/lib_shell_services/store_errors.ml @@ -1170,7 +1170,7 @@ type corruption_kind = | Cannot_find_floating_caboose | Cannot_find_caboose_candidate | Cannot_find_block_with_metadata - | Cannot_find_activation_block of Block_hash.t * int + | Cannot_find_activation_block of int | Missing_genesis let corruption_kind_encoding = @@ -1217,13 +1217,11 @@ let corruption_kind_encoding = case (Tag 6) ~title:"Cannot_find_activation_block" - (obj2 (req "block_hash" Block_hash.encoding) (req "proto_level" int31)) + (obj1 (req "proto_level" int31)) (function - | Cannot_find_activation_block (block_hash, proto_level) -> - Some (block_hash, proto_level) + | Cannot_find_activation_block proto_level -> Some proto_level | _ -> None) - (fun (block_hash, proto_level) -> - Cannot_find_activation_block (block_hash, proto_level)); + (fun proto_level -> Cannot_find_activation_block proto_level); case (Tag 7) ~title:"Missing_genesis" @@ -1256,14 +1254,11 @@ let pp_corruption_kind ppf = function ppf "cannot find block with metadata in the store. At least the head must \ have metadata" - | Cannot_find_activation_block (block_hash, proto_level) -> + | Cannot_find_activation_block proto_level -> Format.fprintf ppf - "failed to find a valid activation block for protocol %d of the \ - current head (%a)" + "failed to find a valid activation block for protocol %d" proto_level - Block_hash.pp - block_hash | Missing_genesis -> Format.fprintf ppf "the genesis block is not available in the store" diff --git a/src/lib_store/shared/store_events.ml b/src/lib_store/shared/store_events.ml index f4ede18b51bf..d39527dc145b 100644 --- a/src/lib_store/shared/store_events.ml +++ b/src/lib_store/shared/store_events.ml @@ -369,6 +369,14 @@ let recover_merge = ~msg:"recovering from an interrupted store merge" () +let restore_protocols_table = + declare_0 + ~section + ~level:Internal_event.Notice + ~name:"restore_protocols_table" + ~msg:"restoring protocols table" + () + let restore_protocol_activation = declare_2 ~section @@ -421,17 +429,6 @@ let restore_inferred_history_mode = ~pp1:History_mode.pp (* Warning *) -let warning_incomplete_storage = - declare_1 - ~level:Internal_event.Warning - ~section - ~name:"incomplete_storage" - ~msg: - "the storage is missing the commit information for protocol \ - {protocol_level} - operation receipt verification for this protocol \ - will be unavailable" - ("protocol_level", Data_encoding.int31) - let warning_missing_metadata = declare_2 ~level:Internal_event.Warning diff --git a/src/lib_store/unix/cemented_block_store.ml b/src/lib_store/unix/cemented_block_store.ml index 5f80ef1c8a6c..25d42bfb7cdb 100644 --- a/src/lib_store/unix/cemented_block_store.ml +++ b/src/lib_store/unix/cemented_block_store.ml @@ -836,49 +836,48 @@ let trigger_gc cemented_store history_mode = in trigger_rolling_gc cemented_store cemented_blocks_files offset) +let raw_iter_cemented_file f ({file; _} as cemented_blocks_file) = + let open Lwt_syntax in + let file_path = Naming.file_path file in + Lwt_io.with_file + ~flags:[Unix.O_RDONLY; O_CLOEXEC] + ~mode:Lwt_io.Input + file_path + (fun channel -> + let nb_blocks = cemented_blocks_file_length cemented_blocks_file in + let* first_block_offset = Lwt_io.BE.read_int channel in + let* () = Lwt_io.set_position channel (Int64.of_int first_block_offset) in + let rec loop n = + if n = 0 then Lwt.return_unit + else + (* Read length *) + let* length = Lwt_io.BE.read_int channel in + let full_length = 4 (* int32 length *) + length in + let block_bytes = Bytes.create full_length in + let* () = Lwt_io.read_into_exactly channel block_bytes 4 length in + Bytes.set_int32_be block_bytes 0 (Int32.of_int length) ; + let* () = + f + (Data_encoding.Binary.of_bytes_exn + Block_repr.encoding + block_bytes) + in + loop (pred n) + in + loop (Int32.to_int nb_blocks)) + let iter_cemented_file f ({file; _} as cemented_blocks_file) = let open Lwt_result_syntax in - protect (fun () -> - let file_path = Naming.file_path file in - Lwt_io.with_file - ~flags:[Unix.O_RDONLY; O_CLOEXEC] - ~mode:Lwt_io.Input - file_path - (fun channel -> - let nb_blocks = cemented_blocks_file_length cemented_blocks_file in - let*! first_block_offset = Lwt_io.BE.read_int channel in - let*! () = - Lwt_io.set_position channel (Int64.of_int first_block_offset) - in - let rec loop n = - if n = 0 then Lwt.return_unit - else - (* Read length *) - let*! length = Lwt_io.BE.read_int channel in - let full_length = 4 (* int32 length *) + length in - let block_bytes = Bytes.create full_length in - let*! () = - Lwt_io.read_into_exactly channel block_bytes 4 length - in - Bytes.set_int32_be block_bytes 0 (Int32.of_int length) ; - let*! () = - f - (Data_encoding.Binary.of_bytes_exn - Block_repr.encoding - block_bytes) - in - loop (pred n) - in - Lwt.catch - (fun () -> - let*! () = loop (Int32.to_int nb_blocks) in - return_unit) - (fun exn -> - Format.kasprintf - (fun trace -> - tzfail (Inconsistent_cemented_file (file_path, trace))) - "%s" - (Printexc.to_string exn)))) + Lwt.catch + (fun () -> + let*! () = raw_iter_cemented_file f cemented_blocks_file in + return_unit) + (fun exn -> + Format.kasprintf + (fun trace -> + tzfail (Inconsistent_cemented_file (Naming.file_path file, trace))) + "%s" + (Printexc.to_string exn)) let check_indexes_consistency ?(post_step = fun () -> Lwt.return_unit) ?genesis_hash cemented_store = diff --git a/src/lib_store/unix/cemented_block_store.mli b/src/lib_store/unix/cemented_block_store.mli index 0edbcd5ba4c2..ad6d6b70ed29 100644 --- a/src/lib_store/unix/cemented_block_store.mli +++ b/src/lib_store/unix/cemented_block_store.mli @@ -272,12 +272,20 @@ val trigger_gc : t -> History_mode.t -> unit Lwt.t (** [iter_cemented_file ~cemented_block_dir f block_file] reads from the cemented [block_file] located in [cemented_block_dir] and - applies [f] on every block. *) + applies [f] on every block. + + {b Warning}: in this version, exceptions are caught. Use [raw_iter_cemented_file] + for manual exception management. *) val iter_cemented_file : (Block_repr.block -> unit Lwt.t) -> cemented_blocks_file -> unit tzresult Lwt.t +(** Unsafe version of [iter_cemented_file] where internal exceptions/errors + are not caught. *) +val raw_iter_cemented_file : + (Block_repr.block -> unit Lwt.t) -> cemented_blocks_file -> unit Lwt.t + (** [check_indexes_consistency ?post_step ?genesis_hash cemented_store history_mode] iterates over a partially initialized [cemented_store] that contains both chunks of blocks and indexes diff --git a/src/lib_store/unix/consistency.ml b/src/lib_store/unix/consistency.ml index b9e24af42675..6c5718a3daf5 100644 --- a/src/lib_store/unix/consistency.ml +++ b/src/lib_store/unix/consistency.ml @@ -475,16 +475,22 @@ let lowest_floating_blocks floating_stores = let lwm = min lwm in return (lw, lwm) +let read_block_at_level ~read_metadata block_store ~head:(head_hash, head_level) + level = + Block_store.read_block + ~read_metadata + block_store + (Block_store.Block (head_hash, Int32.(to_int (sub head_level level)))) + (* Reads and returns the inferred savepoint. *) let load_inferred_savepoint chain_dir block_store head savepoint_level = let open Lwt_result_syntax in let* block = - Block_store.read_block + read_block_at_level ~read_metadata:false block_store - (Block_store.Block - ( Block_repr.hash head, - Int32.(to_int (sub (Block_repr.level head) savepoint_level)) )) + ~head:(Block_repr.descriptor head) + savepoint_level in match block with | Some block -> @@ -511,12 +517,11 @@ let load_inferred_savepoint chain_dir block_store head savepoint_level = let load_inferred_caboose chain_dir block_store head caboose_level = let open Lwt_result_syntax in let* block = - Block_store.read_block + read_block_at_level ~read_metadata:false block_store - (Block_store.Block - ( Block_repr.hash head, - Int32.(to_int (sub (Block_repr.level head) caboose_level)) )) + ~head:(Block_repr.descriptor head) + caboose_level in match block with | Some block -> @@ -663,16 +668,14 @@ let fix_checkpoint chain_dir block_store head = (Corrupted_store (Inferred_head (Block_repr.hash head, Block_repr.level head))) in - let head_hash = Block_repr.hash head in (* Returns the lowest block with metadata *) let rec find_lbwm block_level = let* o = - Block_store.read_block - ~read_metadata:true + read_block_at_level + ~read_metadata:false block_store - (Block_store.Block - ( head_hash, - Int32.(to_int (sub (Block_repr.level head) block_level)) )) + ~head:(Block_repr.descriptor head) + block_level in match o with | Some block -> ( @@ -718,320 +721,316 @@ let fix_checkpoint chain_dir block_store head = in return inferred_checkpoint -(* [fix_protocol_levels context_index block_store genesis_header ~head - ~savepoint] - fixes protocol levels table by searching for all the protocol - levels in the block store (cemented and floating). Fixing this - table is possible in archive mode only. - Assumptions: - - block store is valid and available, - - current head is valid and available. *) -let fix_protocol_levels context_index block_store genesis genesis_header ~head - ~savepoint = +let check_block_protocol_hash context_index ~expected block = let open Lwt_result_syntax in - (* Search in the cemented store*) - let cemented_block_store = Block_store.cemented_block_store block_store in - let cemented_block_files = - match Cemented_block_store.cemented_blocks_files cemented_block_store with - | None -> [] - | Some arr -> Array.to_list arr + protect @@ fun () -> + let*! ctxt = Context.checkout_exn context_index (Block_repr.context block) in + let*! got = Context.get_protocol ctxt in + return Protocol_hash.(got = expected) + +(** Look into the cemented store for the lowest block with an + associated proto level that is above the savepoint. *) +let find_activation_block_in_cemented block_store ~savepoint_level ~proto_level + = + let open Lwt_result_syntax in + let cemented_store = Block_store.cemented_block_store block_store in + let read_cemented_block_by_level level = + let* b_opt = + Cemented_block_store.get_cemented_block_by_level + cemented_store + ~read_metadata:false + level + in + let* b = + match b_opt with + | Some b -> return b + | None -> + failwith + "find_activation_block_in_cemented: unexpected missing block in \ + the cemented store" + in + return b in - (* Iters through the blocks of a cemented cycle from [level] to - [limit] and identify every proto_level changes and its associated - activation block. *) - let cycle_search cemented_block_store ~prev_proto_level ~cycle_start - ~cycle_end:limit = - let rec aux ~prev_proto_level ~level acc = - if Compare.Int32.(level > limit) then return acc - else - let* block_o = - Cemented_block_store.get_cemented_block_by_level - cemented_block_store - ~read_metadata:false - level - in - let block = WithExceptions.Option.get ~loc:__LOC__ block_o in - let block_proto_level = Block_repr.proto_level block in - match prev_proto_level with - | None -> - (* There is no protocol yet known. The genesis protocol - will be handled later, no need to deal with it here.*) - aux - ~prev_proto_level:(Some block_proto_level) - ~level:(Int32.succ level) - acc - | Some previous_proto_level -> - if Compare.Int.(previous_proto_level <> block_proto_level) then - let*! o = - Context.checkout context_index (Block_repr.context block) - in - match o with - | None -> - (* We have an incomplete context (full or rolling) - and thus not enough information to get the - activation. We ignore this protocol change. *) - let*! () = - Store_events.( - emit warning_incomplete_storage block_proto_level) - in - aux - ~prev_proto_level:(Some block_proto_level) - ~level:(Int32.succ level) - acc - | Some context -> - let*! protocol_hash = Context.get_protocol context in - let*! commit_info = - let*! r = - Context.retrieve_commit_info - context_index - (Block_repr.header block) - in - match r with - | Ok tup -> - Lwt.return_some - (Protocol_levels.commit_info_of_tuple tup) - | Error _ -> - let*! () = - Store_events.( - emit warning_incomplete_storage block_proto_level) - in - Lwt.return_none - in - let activation = - ( block_proto_level, - { - Protocol_levels.block = - (Block_repr.hash block, Block_repr.level block); - protocol = protocol_hash; - commit_info; - } ) - in - let*! () = - Store_events.( - emit - restore_protocol_activation - (block_proto_level, protocol_hash)) - in - aux - ~prev_proto_level:(Some block_proto_level) - ~level:(Int32.succ level) - (activation :: acc) - else aux ~prev_proto_level ~level:(Int32.succ level) acc + let* is_in_cemented = + match Cemented_block_store.get_highest_cemented_level cemented_store with + | None -> return_false + | Some level -> + if Compare.Int32.(savepoint_level > level) then return_false + else + let* b = read_cemented_block_by_level level in + return Compare.Int.(Block_repr.proto_level b >= proto_level) + in + if not is_in_cemented then return_none + else + (* If it is in the cemented, iter on the cemented cycles (in reverse) *) + let* cemented_cycles = + match Cemented_block_store.cemented_blocks_files cemented_store with + | None -> + failwith + "find_activation_block_in_cemented: no cycle in the cemented store \ + but got a highest cemented level" + | Some cycles -> return cycles + in + let len = Array.length cemented_cycles in + let rec find_activation_cycle previous_cycle = function + | -1 -> + (* We know that there is at least one cemented cycle, + otherwise, we wouldn't have a cemented highest level *) + let* min_b = + read_cemented_block_by_level + previous_cycle.Cemented_block_store.start_level + in + if Compare.Int.(Block_repr.proto_level min_b <= proto_level) then + return previous_cycle + else + failwith + "find_activation_block_in_cemented: cannot find activation block \ + for proto %d in cemented store" + proto_level + | n -> + let ({Cemented_block_store.start_level; end_level; _} as cycle) = + cemented_cycles.(n) + in + let min_level = Compare.Int32.(max start_level savepoint_level) in + let* min_b = read_cemented_block_by_level min_level in + let* max_b = read_cemented_block_by_level end_level in + let min_proto_level = Block_repr.proto_level min_b in + let max_proto_level = Block_repr.proto_level max_b in + if Compare.Int.(min_proto_level > proto_level) then + (* Too recent *) + find_activation_cycle cycle (pred n) + else if Compare.Int.(max_proto_level < proto_level) then + (* Too high, it must be in the previous cycle *) + return previous_cycle + else if + min_proto_level <= proto_level && proto_level <= max_proto_level + then + (* Activation may have occured in a previous cycle *) + find_activation_cycle cycle (pred n) + else + (* All cases are covered: + (proto_level < min) v (max < proto_level) v + (min <= proto_level <= max) *) + assert false in - aux ~prev_proto_level ~level:cycle_start [] - in - (* Return the list of protocol activation blocks by iterating - through the cemented store. The elements of the returned list are - assumed to be consecutive and sorted in descending order.*) - let rec cemented_search prev_proto_level protocols = function - | [] -> return protocols - | cycle :: higher_cycles -> ( - let cycle_end = cycle.Cemented_block_store.end_level in - let cycle_start = cycle.start_level in - let* block_o = - Cemented_block_store.get_cemented_block_by_level - ~read_metadata:false - cemented_block_store - cycle_end + let* cycle = find_activation_cycle cemented_cycles.(len - 1) (len - 1) in + let exception Found of Block_repr.block in + Lwt.catch + (fun () -> + let*! () = + Cemented_block_store.raw_iter_cemented_file + (fun block -> + if Compare.Int32.(Block_repr.level block < savepoint_level) then + Lwt.return_unit + else if Compare.Int.(Block_repr.proto_level block = proto_level) + then Lwt.fail (Found block) + else Lwt.return_unit) + cycle in - let block = WithExceptions.Option.get ~loc:__LOC__ block_o in - let block_proto_level = Block_repr.proto_level block in - match prev_proto_level with - | None -> - (* Search a protocol upgrade in the cycle as init *) - let* activations = - cycle_search - (Block_store.cemented_block_store block_store) - ~prev_proto_level - ~cycle_start - ~cycle_end - in - cemented_search - (Some block_proto_level) - (activations @ protocols) - higher_cycles - | Some previous_proto_level - when Compare.Int.(previous_proto_level <> block_proto_level) -> - (* At least one protocol transition occurs in this cycle *) - let* activations = - cycle_search - (Block_store.cemented_block_store block_store) - ~prev_proto_level - ~cycle_start - ~cycle_end - in - cemented_search - (Some block_proto_level) - (activations @ protocols) - higher_cycles - | Some _ -> - (* No protocol change in this cycle *) - cemented_search prev_proto_level protocols higher_cycles) - in - let* cemented_protocol_levels = - cemented_search None [] cemented_block_files - in - let* highest_cemented_proto_level = - match cemented_protocol_levels with - | [] -> return 0 - | (_, {block = _, block_level; _}) :: _ -> - let* block_o = - Cemented_block_store.get_cemented_block_by_level - ~read_metadata:false - cemented_block_store - block_level + failwith "find_activation_block_in_cemented: cannot read cemented cycle") + (function + | Found block -> return_some block + | exn -> + tzfail + (Inconsistent_cemented_file + (Naming.file_path cycle.file, Printexc.to_string exn))) + +let find_activation_block_in_floating block_store ~head ~savepoint_level + ~proto_level = + let open Lwt_result_syntax in + let rec loop block_proto_level block = + if Compare.Int32.(Block_repr.level block <= savepoint_level) then + let* () = + fail_unless + (Block_repr.proto_level block = proto_level) + (Corrupted_store (Cannot_find_activation_block proto_level)) + in + return block + else + let* predecessor_opt = + Block_store.read_block + ~read_metadata:false + block_store + (Block (Block_repr.hash block, 1)) + in + let predecessor = + (* This block is between savepoint and head: it is expected to + be available *) + WithExceptions.Option.get ~loc:__LOC__ predecessor_opt + in + let predecessor_proto_level = Block_repr.proto_level predecessor in + if + Compare.Int.( + predecessor_proto_level < block_proto_level + && block_proto_level = proto_level) + then (* Found *) + return block + else (* Continue *) + loop predecessor_proto_level predecessor + in + loop (Block_repr.proto_level head) head + +let craft_activation_block context_index block = + let open Lwt_result_syntax in + protect @@ fun () -> + let* commit_info = + Lwt.catch + (fun () -> + let* tup = + Context.retrieve_commit_info context_index (Block_repr.header block) in - let block = WithExceptions.Option.get ~loc:__LOC__ block_o in - return (Block_repr.proto_level block) + return_some (Protocol_levels.commit_info_of_tuple tup)) + (fun _ -> return_none) in - let floating_stores = Block_store.floating_block_stores block_store in - (* Search protocol activation in the floating stores by iterating - over RO and RW. The elements of the returned list are assumed to - be consecutive and sorted in ascending order (as floating_stores - = [RO;RW]). *) - let* floating_protocol_levels = - let+ v = - List.map_es - (Floating_block_store.fold_left_s - (fun (pls, previous_protocol_level) block -> - let new_proto_level = Block_repr.proto_level block in - if Compare.Int.(new_proto_level <> previous_protocol_level) then - let*! o = - Context.checkout context_index (Block_repr.context block) - in - match o with - | None -> - (* We have an incomplete context (full or rolling) - and thus not enough information to get the - activation. We ignore this protocol change. *) - let*! () = - Store_events.( - emit warning_incomplete_storage new_proto_level) - in - return (pls, new_proto_level) - | Some context -> - let*! protocol_hash = Context.get_protocol context in - let*! commit_info = - let*! r = - Context.retrieve_commit_info - context_index - (Block_repr.header block) - in - match r with - | Ok tup -> - Lwt.return_some - (Protocol_levels.commit_info_of_tuple tup) - | Error _ -> - let*! () = - Store_events.( - emit warning_incomplete_storage new_proto_level) - in - Lwt.return_none - in - let activation = - ( new_proto_level, - { - Protocol_levels.block = - (Block_repr.hash block, Block_repr.level block); - protocol = protocol_hash; - commit_info; - } ) - in - let*! () = - Store_events.( - emit - restore_protocol_activation - (new_proto_level, protocol_hash)) - in - return (activation :: pls, new_proto_level) - else return (pls, previous_protocol_level)) - ([], highest_cemented_proto_level)) - floating_stores + let*! protocol = + let*! ctxt = + Context.checkout_exn context_index (Block_repr.context block) in - List.flatten (List.map fst v) + Context.get_protocol ctxt + in + return + {Protocol_levels.block = Block_repr.descriptor block; protocol; commit_info} + +let find_lowest_block_with_proto_level block_store ~head ~savepoint_level + proto_level = + let open Lwt_result_syntax in + let* activation_block = + find_activation_block_in_cemented block_store ~savepoint_level ~proto_level in - (* Add the genesis protocol *) - let protocol = genesis.Genesis.protocol in - let*! genesis_commit_info = - let*! r = Context.retrieve_commit_info context_index genesis_header in + match activation_block with + | Some b -> return b + | None -> + find_activation_block_in_floating + block_store + ~head + ~savepoint_level + ~proto_level + +(* Fixes protocol levels table by searching for all the protocol + levels in the block store (cemented and floating). A complete fix + of this table is possible in archive mode only. In Full and Rolling + modes, only the protocol with an activation block associated to a + stored context will be fully recoverable. To temper with this + restriction, we also consider the existing protocol table, + if it is available, and trust the uncheckable entries. + Assumptions: + - block store is valid and available, + - head is valid and available. + - savepoint is valid and available. *) +let fix_protocol_levels chain_dir block_store context_index + ~savepoint:(savepoint_hash, _) ~head = + let open Lwt_result_syntax in + (* Attempt to recover with the previous protocol table. *) + let*! (stored_protocol_levels : 'a Protocol_levels.t) = + let*! r = Stored_data.load (Naming.protocol_levels_file chain_dir) in match r with - | Ok tup -> Lwt.return_some (Protocol_levels.commit_info_of_tuple tup) - | Error _ -> Lwt.return_none + | Error _ -> Lwt.return Protocol_levels.empty + | Ok v -> Stored_data.get v in - let genesis_protocol_level = - ( 0, - { - Protocol_levels.block = - (Block_header.hash genesis_header, genesis_header.shell.level); - protocol; - commit_info = genesis_commit_info; - } ) - in - (* [finalize_protocol_levels] aims to aggregate the protocol levels - found in the cemented and floating stores.*) - let finalize_protocol_levels genesis_protocol_level cemented_protocol_levels - floating_protocol_levels = - let all_found = - genesis_protocol_level - :: (List.rev cemented_protocol_levels @ floating_protocol_levels) - in - let corrupted_store head_proto_level head_hash = - tzfail - (Corrupted_store - (Cannot_find_activation_block (head_hash, head_proto_level))) - in - (* Make sure that the protocol of the current head is registered. If - not, set it to the savepoint. *) - let head_proto_level = Block_repr.proto_level head in - let head_hash = Block_repr.hash head in - if - not - (List.mem - ~equal:Compare.Int.equal - head_proto_level - (List.map fst all_found)) - then - let* savepoint = - let* o = - Block_store.read_block - ~read_metadata:true - block_store - (Block_store.Block (fst savepoint, 0)) - in - match o with - | None -> corrupted_store head_proto_level head_hash - | Some savepoint -> return savepoint - in - let*! o = Context.checkout context_index (Block_repr.context savepoint) in - match o with - | None -> corrupted_store head_proto_level head_hash - | Some context -> - let*! protocol_hash = Context.get_protocol context in - let* commit_info = - let*! r = - Context.retrieve_commit_info - context_index - (Block_repr.header savepoint) + let* savepoint_opt = + Block_store.read_block + ~read_metadata:false + block_store + (Block (savepoint_hash, 0)) + in + (* We already checked that the savepoint is present, it is safe to + unopt them. *) + let savepoint = WithExceptions.Option.get ~loc:__LOC__ savepoint_opt in + let savepoint_proto_level = Block_repr.proto_level savepoint in + let head_proto_level = Block_repr.proto_level head in + let protocol_levels_geq_savepoint = + savepoint_proto_level -- head_proto_level + in + let* invalid_proto_levels = + List.fold_left_es + (fun invalid_protocol_levels proto_level -> + match Protocol_levels.find_opt proto_level stored_protocol_levels with + | None -> return (proto_level :: invalid_protocol_levels) + | Some activation_block -> ( + let activation_block_level = + snd activation_block.Protocol_levels.block in - match r with - | Ok tup -> return_some (Protocol_levels.commit_info_of_tuple tup) - | Error _ -> corrupted_store head_proto_level head_hash - in - let head_protocol_activation = - ( head_proto_level, - { - Protocol_levels.block = (head_hash, Block_repr.level head); - protocol = protocol_hash; - commit_info; - } ) - in - return (all_found @ [head_protocol_activation]) - else return all_found + let level_to_read = + if + Compare.Int32.( + activation_block_level < Block_repr.level savepoint) + then ( + (* If the activation block is below the savepoint, it + must mean that its proto level is the same as the + savepoint's. Otherwise, the chain contains non + incremental proto levels. *) + assert (Compare.Int.(proto_level = savepoint_proto_level)) ; + Block_repr.level savepoint) + else activation_block_level + in + let* b_opt = + read_block_at_level + ~read_metadata:false + block_store + ~head:(Block_repr.descriptor head) + level_to_read + in + match b_opt with + | None -> + (* The block should be readable, this protocol level is invalid *) + return (proto_level :: invalid_protocol_levels) + | Some b -> + let* protocol_matches = + check_block_protocol_hash + context_index + ~expected:activation_block.protocol + b + in + if protocol_matches then return invalid_protocol_levels + else + (* if the protocol isn't the same as the expected + one, mark this proto level as invalid *) + return (proto_level :: invalid_protocol_levels))) + [] + protocol_levels_geq_savepoint in - finalize_protocol_levels - genesis_protocol_level - cemented_protocol_levels - floating_protocol_levels + let*! () = + if List.compare_lengths [] invalid_proto_levels = 0 then + Store_events.(emit restore_protocols_table ()) + else Lwt.return_unit + in + let correct_protocol_levels = + (* Remove invalid proto levels from the existing stored table *) + Protocol_levels.filter + (fun i _ -> not (List.mem ~equal:Int.equal i invalid_proto_levels)) + stored_protocol_levels + in + (* For each protocol level equal or above the savepoint's that is + invalid: + - Retrieve the *lowest* block in the range [savepoint;head] + that has this protocol level. + - Add it to the existing correct protocol levels *) + let* fixed_protocol_levels = + List.fold_left_es + (fun fixed_protocol_levels invalid_proto_level -> + let* b = + find_lowest_block_with_proto_level + block_store + ~head + ~savepoint_level:(Block_repr.level savepoint) + invalid_proto_level + in + let* activation_block = craft_activation_block context_index b in + let*! () = + Store_events.( + emit + restore_protocol_activation + (invalid_proto_level, activation_block.protocol)) + in + return + (Protocol_levels.add + invalid_proto_level + activation_block + fixed_protocol_levels)) + correct_protocol_levels + invalid_proto_levels + in + return fixed_protocol_levels (* [fix_chain_state chain_dir ~head ~cementing_highwatermark ~checkpoint ~savepoint ~caboose ~alternate_heads ~forked_chains @@ -1042,24 +1041,13 @@ let fix_chain_state chain_dir block_store ~head ~cementing_highwatermark ~forked_chains ~protocol_levels ~chain_config ~genesis ~genesis_context = let open Lwt_result_syntax in (* By setting each stored data, we erase the previous content. *) - let rec init_protocol_table protocol_table = function - | [] -> protocol_table - | (proto_level, proto_hash) :: tl -> - let new_protocol_table = - Protocol_levels.add proto_level proto_hash protocol_table - in - init_protocol_table new_protocol_table tl - in - let protocol_table = - init_protocol_table Protocol_levels.empty protocol_levels - in let* () = Stored_data.write_file (Naming.chain_config_file chain_dir) chain_config in let* () = Stored_data.write_file (Naming.protocol_levels_file chain_dir) - protocol_table + protocol_levels in let genesis_block = Block_repr.create_genesis_block ~genesis genesis_context @@ -1259,13 +1247,7 @@ let fix_consistency ?history_mode chain_dir context_index genesis = savepoint in let* protocol_levels = - fix_protocol_levels - context_index - block_store - genesis - (Block_repr.header genesis_block) - ~head - ~savepoint + fix_protocol_levels chain_dir block_store context_index ~savepoint ~head in let* () = fix_chain_state -- GitLab From 4001bae208a9244ec1599549e3b7f44949ca2770 Mon Sep 17 00:00:00 2001 From: vbot Date: Tue, 4 Oct 2022 16:02:51 +0200 Subject: [PATCH 3/4] Store/Consistency: make caboose as savepoint when savepoint is lower --- src/lib_store/unix/consistency.ml | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/src/lib_store/unix/consistency.ml b/src/lib_store/unix/consistency.ml index 6c5718a3daf5..ed2f1a260260 100644 --- a/src/lib_store/unix/consistency.ml +++ b/src/lib_store/unix/consistency.ml @@ -551,7 +551,7 @@ let infer_savepoint_and_caboose chain_dir block_store = let cemented_caboose_candidate = lowest_cemented_block cemented_block_files in let floating_stores = Block_store.floating_block_stores block_store in match (cemented_savepoint_candidate, cemented_caboose_candidate) with - | Some cemented_savepoint, Some caboose -> + | Some cemented_savepoint, Some cemented_caboose -> (* Cemented candidates are available. However, we must check that the lowest block with metadata from the floating store is not lower than the cemented candidate and thus, a better @@ -569,8 +569,11 @@ let infer_savepoint_and_caboose chain_dir block_store = else cemented_savepoint | None -> cemented_savepoint in - return (sp, caboose) - | None, Some caboose_level -> + let cb = + if Compare.Int32.(cemented_caboose > sp) then sp else cemented_caboose + in + return (sp, cb) + | None, Some cemented_caboose -> (* No cemented cycle with metadata but some cycles. Search for the savepoint in the floating blocks. *) let* _, lowest_floating_with_metadata = @@ -581,6 +584,11 @@ let infer_savepoint_and_caboose chain_dir block_store = | Some lvl -> return lvl | None -> tzfail (Corrupted_store Cannot_find_floating_savepoint) in + let caboose_level = + if Compare.Int32.(cemented_caboose > savepoint_level) then + savepoint_level + else cemented_caboose + in return (savepoint_level, caboose_level) | None, None -> (* No cycle found. Searching for savepoint and caboose in the -- GitLab From 539acf6c8a8c830e1666d10efdf436cf348837d8 Mon Sep 17 00:00:00 2001 From: vbot Date: Tue, 4 Oct 2022 16:17:09 +0200 Subject: [PATCH 4/4] Store/Tests: add a restore consistency test for protocol levels --- src/lib_store/unix/test/test.ml | 1 + src/lib_store/unix/test/test_consistency.ml | 300 ++++++++++++++++++++ src/lib_store/unix/test/test_store.ml | 2 +- src/lib_store/unix/test/test_utils.ml | 60 +++- 4 files changed, 353 insertions(+), 10 deletions(-) create mode 100644 src/lib_store/unix/test/test_consistency.ml diff --git a/src/lib_store/unix/test/test.ml b/src/lib_store/unix/test/test.ml index 278a05bcc804..437bb0f17605 100644 --- a/src/lib_store/unix/test/test.ml +++ b/src/lib_store/unix/test/test.ml @@ -43,6 +43,7 @@ let () = Test_cemented_store.tests; Test_block_store.tests; Test_store.tests; + Test_consistency.tests; Test_protocol_store.tests; Test_testchain.tests; Test_snapshots.tests speed; diff --git a/src/lib_store/unix/test/test_consistency.ml b/src/lib_store/unix/test/test_consistency.ml new file mode 100644 index 000000000000..7df6d3a6fc68 --- /dev/null +++ b/src/lib_store/unix/test/test_consistency.ml @@ -0,0 +1,300 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic Labs, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Test_utils + +let nb_protocols = 5 + +let init_protocols store history_mode = + let open Lwt_result_syntax in + let chain_store = Store.main_chain_store store in + assert (History_mode.equal (Store.Chain.history_mode chain_store) history_mode) ; + let mk i = + let s = string_of_int i in + let proto = + { + Protocol.expected_env = V0; + components = [{name = s; interface = None; implementation = s}]; + } + in + (Protocol.hash proto, proto) + in + let protos = Stdlib.List.init nb_protocols mk in + let*! () = + List.iter_s + (fun (h, p) -> + let*! r = Store.Protocol.store store h p in + assert (r <> None) ; + Lwt.return_unit) + protos + in + assert (List.for_all (Store.Protocol.mem store) (List.map fst protos)) ; + let blocks_proto = List.mapi (fun i p -> (succ i, fst p)) protos in + (* 10 blocks per cycle *) + let nb_blocks_per_cycle = 10 in + let constants = + { + Test_utils.default_protocol_constants with + blocks_per_cycle = Int32.of_int nb_blocks_per_cycle; + preserved_cycles = 1; + } + in + let* () = + List.iter_es + (fun (protocol_level, proto_hash) -> + let*! pred = Store.Chain.current_head chain_store in + let* bl, _ = + append_blocks + ~constants + ~max_operations_ttl:8 + ~kind:`Full + ~should_set_head:true + ~should_commit:true + ~protocol_level + ~set_protocol:proto_hash + chain_store + nb_blocks_per_cycle + in + let first_block_of_cycle = Stdlib.List.hd bl in + let* () = + Store.Chain.may_update_protocol_level + chain_store + ~pred + ~protocol_level + (first_block_of_cycle, proto_hash) + in + let*! () = + Block_store.await_merging (Store.Unsafe.get_block_store chain_store) + in + return_unit) + blocks_proto + in + let*! all_proto_levels = Store.Chain.all_protocol_levels chain_store in + let open Store_types in + let*! _savepoint, savepoint_level = Store.Chain.savepoint chain_store in + let* () = + Protocol_levels.iter_es + (fun proto_level activation_block -> + let activation_block_hash, activation_block_level = + activation_block.Protocol_levels.block + in + (* We cannot consider gc-ed blocks *) + if activation_block_level < Int32.succ savepoint_level then return_unit + else + let* activation_block = + Store.Block.read_block chain_store activation_block_hash + in + let* pred = + Store.Block.read_predecessor chain_store activation_block + in + assert (Store.Block.proto_level activation_block = proto_level) ; + assert ( + Store.Block.proto_level pred = Int.pred proto_level + || proto_level = 0) ; + return_unit) + all_proto_levels + in + let*! () = Store.close_store store in + return (store, all_proto_levels) + +let test_protocol_level_consistency_drop_one history_mode nth + (store_dir, context_dir) store = + let open Lwt_result_syntax in + assert (nth < 5) ; + let* store, _ = init_protocols store history_mode in + let chain_store = Store.main_chain_store store in + (* Close the store and remove a protocol level between savepoint and head *) + let chain_id = Store.Chain.chain_id chain_store in + let protocol_level_file = + let dir = store_dir in + let open Naming in + store_dir ~dir_path:dir |> fun d -> + chain_dir d chain_id |> protocol_levels_file + in + let*! () = Lwt_unix.unlink (Naming.encoded_file_path protocol_level_file) in + let*! all_proto_levels = Store.Chain.all_protocol_levels chain_store in + let*! _ = + let proto_l = Store_types.Protocol_levels.bindings all_proto_levels in + let protos = + Store_types.Protocol_levels.of_seq + (List.to_seq (List.take_n nth proto_l @ List.drop_n (nth + 1) proto_l)) + in + Stored_data.init protocol_level_file ~initial_data:protos + in + let* store = + Store.init + ~patch_context:dummy_patch_context + ~history_mode + ~store_dir + ~context_dir + ~allow_testchains:true + genesis + in + (* Check that between the savepoint and the head, all protocol + levels are known and correct. *) + let chain_store = Store.main_chain_store store in + let*! current_head = Store.Chain.current_head chain_store in + let*! _savepoint, savepoint_level = Store.Chain.savepoint chain_store in + let* () = + List.iter_es + (fun l -> + let* b = Store.Block.read_block_by_level chain_store (Int32.of_int l) in + let*! proto_opt = + Store.Chain.find_protocol + chain_store + ~protocol_level:(Store.Block.proto_level b) + in + let* proto = + match proto_opt with + | Some proto -> return proto + | None -> + failwith + "unexpected missing proto level %d in the protocol levels" + (Store.Block.proto_level b) + in + let*! ctxt = Store.Block.context_exn chain_store b in + let*! proto_block = Context_ops.get_protocol ctxt in + assert (Protocol_hash.(proto = proto_block)) ; + return_unit) + (Int32.to_int savepoint_level + -- Int32.to_int (Store.Block.level current_head)) + in + return_unit + +let check_protocol_levels_availability chain_store ~expected_protocols + ~recovered_protocols = + let open Lwt_result_syntax in + let open Store_types in + let*! savepoint_hash, _ = Store.Chain.savepoint chain_store in + let* savepoint = Store.Block.read_block chain_store savepoint_hash in + let savepoint_proto_level = Store.Block.proto_level savepoint in + Protocol_levels.iter_es + (fun proto_level _ -> + if proto_level < savepoint_proto_level then + assert (not (Protocol_levels.mem proto_level recovered_protocols)) + else if proto_level >= savepoint_proto_level then + let recovered_activation_block = + Protocol_levels.find proto_level recovered_protocols + in + match recovered_activation_block with + | None -> assert false + | Some {Protocol_levels.commit_info; _} -> + assert (Option.is_some commit_info) + else assert false ; + return_unit) + expected_protocols + +let test_protocol_level_consistency_remove_file history_mode + (store_dir, context_dir) store = + let open Lwt_result_syntax in + let* store, expected_protocols = init_protocols store history_mode in + let open Store_types in + let chain_store = Store.main_chain_store store in + (* Close the store and remove a protocol level between savepoint and head *) + let chain_id = Store.Chain.chain_id chain_store in + let protocol_level_file = + let dir = store_dir in + let open Naming in + store_dir ~dir_path:dir |> fun d -> + chain_dir d chain_id |> protocol_levels_file + in + let*! () = Lwt_unix.unlink (Naming.encoded_file_path protocol_level_file) in + let*! _ = + Stored_data.init protocol_level_file ~initial_data:Protocol_levels.empty + in + let* store = + Store.init + ~patch_context:dummy_patch_context + ~history_mode + ~store_dir + ~context_dir + ~allow_testchains:true + genesis + in + (* Check that between the savepoint and the head, all protocol + levels are known and correct. *) + let chain_store = Store.main_chain_store store in + let*! current_head = Store.Chain.current_head chain_store in + let*! _savepoint, savepoint_level = Store.Chain.savepoint chain_store in + let* () = + List.iter_es + (fun l -> + let* b = Store.Block.read_block_by_level chain_store (Int32.of_int l) in + let*! proto_opt = + Store.Chain.find_protocol + chain_store + ~protocol_level:(Store.Block.proto_level b) + in + let* proto = + match proto_opt with + | Some proto -> return proto + | None -> + failwith + "unexpected missing proto level %d in the protocol levels" + (Store.Block.proto_level b) + in + let*! ctxt = Store.Block.context_exn chain_store b in + let*! proto_block = Context_ops.get_protocol ctxt in + assert (Protocol_hash.(proto = proto_block)) ; + return_unit) + (Int32.to_int savepoint_level + -- Int32.to_int (Store.Block.level current_head)) + in + let*! recovered_protocols = Store.Chain.all_protocol_levels chain_store in + let* () = + check_protocol_levels_availability + chain_store + ~expected_protocols + ~recovered_protocols + in + return_unit + +let make_tests = + let history_modes = History_mode.[Rolling (Some {offset = 1}); Archive] in + let tests = + Stdlib.List.init 5 (fun i history_mode -> + ( Format.asprintf + "protocol level consistency (%a): drop protocol #%d" + History_mode.pp + history_mode + (i + 1), + test_protocol_level_consistency_drop_one history_mode i )) + @ [ + (fun history_mode -> + ( Format.asprintf + "protocol level consistency (%a): remove file" + History_mode.pp + history_mode, + test_protocol_level_consistency_remove_file history_mode )); + ] + in + List.map (fun (hm, test) -> (hm, test hm)) List.(product history_modes tests) + +let tests = + ( "consistency", + List.map + (fun (history_mode, test) -> + wrap_test ~block_cache_limit:1 ~history_mode ~manual_close:true test) + make_tests ) diff --git a/src/lib_store/unix/test/test_store.ml b/src/lib_store/unix/test/test_store.ml index ff94245bed6b..6dd9fa331a99 100644 --- a/src/lib_store/unix/test/test_store.ml +++ b/src/lib_store/unix/test/test_store.ml @@ -39,7 +39,7 @@ let test_cycles store = in assert_presence_in_store chain_store blocks -let test_cases = [wrap_test ("store cycles", fun _ store -> test_cycles store)] +let test_cases = [wrap_test ("store cycles", fun _ -> test_cycles)] open Example_tree diff --git a/src/lib_store/unix/test/test_utils.ml b/src/lib_store/unix/test/test_utils.ml index eb9534309e31..b3b08da6d56a 100644 --- a/src/lib_store/unix/test/test_utils.ml +++ b/src/lib_store/unix/test/test_utils.ml @@ -193,7 +193,8 @@ let register_gc store = let wrap_store_init ?(patch_context = dummy_patch_context) ?(history_mode = History_mode.Archive) ?(allow_testchains = true) - ?(keep_dir = false) ?(with_gc = true) k _ () : unit Lwt.t = + ?(keep_dir = false) ?(with_gc = true) ?block_cache_limit + ?(manual_close = false) k _ () : unit Lwt.t = let open Lwt_result_syntax in let prefix_dir = "tezos_indexed_store_test_" in let run f = @@ -211,6 +212,7 @@ let wrap_store_init ?(patch_context = dummy_patch_context) let context_dir = base_dir // "context" in let* store = Store.init + ?block_cache_limit ~patch_context ~history_mode ~store_dir @@ -223,13 +225,20 @@ let wrap_store_init ?(patch_context = dummy_patch_context) ~on_error:(fun err -> let*! pp_store = Store.make_pp_store store in Format.eprintf "@[DEBUG:@ %a@]@." pp_store () ; - let*! () = Store.close_store store in + let*! () = + if manual_close then Lwt.return_unit else Store.close_store store + in Lwt.return (Error err)) (fun () -> let* () = k (store_dir, context_dir) store in Format.printf "Invariants check before closing@." ; - let* () = check_invariants (Store.main_chain_store store) in - let*! () = Store.close_store store in + let* () = + if manual_close then return_unit + else + let* () = check_invariants (Store.main_chain_store store) in + let*! () = Store.close_store store in + return_unit + in let* store' = Store.init ~history_mode @@ -255,11 +264,18 @@ let wrap_store_init ?(patch_context = dummy_patch_context) | Ok r -> Lwt.return r let wrap_test ?history_mode ?(speed = `Quick) ?patch_context ?keep_dir ?with_gc - (name, f) = + ?block_cache_limit ?manual_close (name, f) = test_case name speed - (wrap_store_init ?patch_context ?history_mode ?keep_dir ?with_gc f) + (wrap_store_init + ?patch_context + ?history_mode + ?keep_dir + ?with_gc + ?block_cache_limit + ?manual_close + f) let wrap_simple_store_init ?(patch_context = dummy_patch_context) ?(history_mode = History_mode.default) ?(allow_testchains = true) @@ -512,8 +528,22 @@ let make_raw_block_list ?min_lafl ?constants ?max_operations_ttl ?(kind = `Full) let blk = List.hd l |> WithExceptions.Option.get ~loc:__LOC__ in Lwt.return (List.rev l, blk) +let incr_fitness b = + match b with + | [] -> + let b = Bytes.create 8 in + Bytes.set_int32_be b 0 1l ; + [b] + | [fitness_b] -> + let fitness = Bytes.get_int32_be fitness_b 0 in + let b = Bytes.create 8 in + Bytes.set_int32_be b 0 (Int32.succ fitness) ; + [b] + | _ -> assert false + let append_blocks ?min_lafl ?constants ?max_operations_ttl ?root ?(kind = `Full) - ?(should_set_head = false) ?(should_commit = false) chain_store n = + ?(should_set_head = false) ?(should_commit = false) ?protocol_level + ?set_protocol chain_store n = let open Lwt_result_syntax in let*! root = match root with @@ -531,6 +561,11 @@ let append_blocks ?min_lafl ?constants ?max_operations_ttl ?root ?(kind = `Full) let*! blocks, _last = make_raw_block_list ?min_lafl ?constants ?max_operations_ttl ~kind root n in + let proto_level = + match protocol_level with + | None -> Store.Block.proto_level root_b + | Some proto_level -> proto_level + in let* _, _, blocks = List.fold_left_es (fun (ctxt_opt, last_opt, blocks) b -> @@ -543,17 +578,24 @@ let append_blocks ?min_lafl ?constants ?max_operations_ttl ?root ?(kind = `Full) ["level"] (Bytes.of_string (Format.asprintf "%ld" (Block_repr.level b))) in + let*! ctxt = + match set_protocol with + | None -> Lwt.return ctxt + | Some proto -> Context_ops.add_protocol ctxt proto + in let*! ctxt_hash = Context_ops.commit ~time:Time.Protocol.epoch ctxt in let predecessor = - Option.value ~default:(Block_repr.predecessor b) last_opt + match List.hd blocks with None -> root_b | Some pred -> pred in let shell = { b.contents.header.Block_header.shell with + fitness = incr_fitness (Store.Block.fitness predecessor); + proto_level; context = ctxt_hash; - predecessor; + predecessor = Store.Block.hash predecessor; } in let header = -- GitLab