diff --git a/src/lib_protocol_environment/shell_context.ml b/src/lib_protocol_environment/shell_context.ml index 71a76128a4a0229cc71bf2b7ba621ceaf712d3ea..4fe960a61d243a0d56c79fbcfd0dcaf188b0837c 100644 --- a/src/lib_protocol_environment/shell_context.ml +++ b/src/lib_protocol_environment/shell_context.ml @@ -42,6 +42,25 @@ module C = struct let remove_rec = remove let set_protocol = add_protocol + + let copy ctxt ~from ~to_ = + find_tree ctxt from + >>= function + | None -> + Lwt.return_none + | Some sub_tree -> + add_tree ctxt to_ sub_tree >>= Lwt.return_some + + type key_or_dir = [`Key of key | `Dir of key] + + let fold t root ~init ~f = + fold ~depth:(`Eq 1) t root ~init ~f:(fun k t acc -> + let k = root @ k in + match Tree.kind t with + | `Value _ -> + f (`Key k) acc + | `Tree -> + f (`Dir k) acc) end let ops = (module C : CONTEXT with type t = 'ctxt) diff --git a/src/lib_shell/block_directory.ml b/src/lib_shell/block_directory.ml index 82b6fa3ea5829a3f5697ccea16a2d96c8eaf8210..be37586e99603f754ba661c6bc1219a3e8de0705 100644 --- a/src/lib_shell/block_directory.ml +++ b/src/lib_shell/block_directory.ml @@ -34,12 +34,12 @@ let rec read_partial_context context path depth = Lwt.return (Block_services.Key v) | None -> (* try to read as directory *) - Context.fold context path ~init:[] ~f:(fun k acc -> - match k with - | `Key [] | `Dir [] -> + Context.fold ~depth:(`Eq 1) context path ~init:[] ~f:(fun k _ acc -> + match path @ k with + | [] -> (* This is an invariant of {!Context.fold} *) assert false - | `Key (khd :: ktl as k) | `Dir (khd :: ktl as k) -> + | khd :: ktl as k -> read_partial_context context k (depth - 1) >>= fun v -> let k = List.last khd ktl in diff --git a/src/lib_storage/context.ml b/src/lib_storage/context.ml index 59d4e68fd7b54b0a35e226f87544bc39bb023995..c166337d4b857c8eba8a7ea18e6abb8787852aa4 100644 --- a/src/lib_storage/context.ml +++ b/src/lib_storage/context.ml @@ -218,15 +218,15 @@ module Commit = struct end module Contents = struct - type t = string + type t = bytes - let ty = Irmin.Type.(pair (string_of `Int64) unit) + let ty = Irmin.Type.(pair (bytes_of `Int64) unit) let pre_hash_ty = Irmin.Type.(unstage (pre_hash ty)) let pre_hash_v1 x = pre_hash_ty (x, ()) - let t = Irmin.Type.(like string ~pre_hash:(stage @@ fun x -> pre_hash_v1 x)) + let t = Irmin.Type.(like bytes ~pre_hash:(stage @@ fun x -> pre_hash_v1 x)) let merge = Irmin.Merge.(idempotent (Irmin.Type.option t)) end @@ -264,6 +264,8 @@ and context = {index : index; parents : Store.Commit.t list; tree : Store.tree} type t = context +module type S = Context_intf.S + (*-- Version Access and Update -----------------------------------------------*) let current_protocol_key = ["protocol"] @@ -371,56 +373,141 @@ type key = string list type value = bytes -let mem ctxt key = - Store.Tree.mem ctxt.tree (data_key key) >>= fun v -> Lwt.return v +type tree = Store.tree + +module Tree = struct + include Store.Tree + + let empty _ = Store.Tree.empty + + let equal = Irmin.Type.(unstage (equal Store.tree_t)) + + let is_empty t = equal Store.Tree.empty t + + let hash t = Hash.to_context_hash (Store.Tree.hash t) -let mem_tree ctxt key = - Store.Tree.mem_tree ctxt.tree (data_key key) >>= fun v -> Lwt.return v + let add t k v = Store.Tree.add t k v -let raw_find ctxt key = - Store.Tree.find ctxt.tree key >|= Option.map Bytes.of_string + let kind t = + match Store.Tree.destruct t with + | `Contents (c, _) -> + `Value c + | `Node _ -> + `Tree -let find t key = raw_find t (data_key key) + let fold ?depth t k ~init ~f = + find_tree t k + >>= function + | None -> + Lwt.return init + | Some t -> + Store.Tree.fold + ?depth + ~force:`And_clear + ~uniq:`False + ~node:(fun k v acc -> f k (Store.Tree.of_node v) acc) + ~contents:(fun k v acc -> + if k = [] then Lwt.return acc + else f k (Store.Tree.of_contents v) acc) + t + init + + type raw = [`Value of bytes | `Tree of raw TzString.Map.t] + + type concrete = Store.Tree.concrete + + let rec raw_of_concrete : type a. (raw -> a) -> concrete -> a = + fun k -> function + | `Tree l -> + raw_of_node (fun l -> k (`Tree (TzString.Map.of_seq l))) l + | `Contents (v, _) -> + k (`Value v) + + and raw_of_node : + type a. ((string * raw) Seq.t -> a) -> (string * concrete) list -> a = + fun k -> function + | [] -> + k Seq.empty + | (n, v) :: t -> + raw_of_concrete + (fun v -> + raw_of_node (fun t -> k (fun () -> Seq.Cons ((n, v), t))) t) + v + + let to_raw t = Store.Tree.to_concrete t >|= raw_of_concrete (fun t -> t) + + let rec concrete_of_raw : type a. (concrete -> a) -> raw -> a = + fun k -> function + | `Tree l -> + concrete_of_node (fun l -> k (`Tree l)) (TzString.Map.to_seq l) + | `Value v -> + k (`Contents (v, ())) + + and concrete_of_node : + type a. ((string * concrete) list -> a) -> (string * raw) Seq.t -> a = + fun k seq -> + match seq () with + | Nil -> + k [] + | Cons ((n, v), t) -> + concrete_of_raw + (fun v -> concrete_of_node (fun t -> k ((n, v) :: t)) t) + v + + let of_raw = concrete_of_raw Store.Tree.of_concrete + + let raw_encoding : raw Data_encoding.t = + let open Data_encoding in + mu "Tree.raw" (fun encoding -> + let map_encoding = + conv + TzString.Map.bindings + (fun bindings -> TzString.Map.of_seq (List.to_seq bindings)) + (list (tup2 string encoding)) + in + union + [ case + ~title:"tree" + (Tag 0) + map_encoding + (function `Tree t -> Some t | `Value _ -> None) + (fun t -> `Tree t); + case + ~title:"value" + (Tag 1) + bytes + (function `Value v -> Some v | `Tree _ -> None) + (fun v -> `Value v) ]) +end + +let mem ctxt key = Tree.mem ctxt.tree (data_key key) + +let mem_tree ctxt key = Tree.mem_tree ctxt.tree (data_key key) + +let raw_find ctxt key = Tree.find ctxt.tree key + +let list ctxt ?offset ?length key = + Tree.list ctxt.tree ?offset ?length (data_key key) + +let find ctxt key = raw_find ctxt (data_key key) 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} + Tree.add ctxt.tree key data >|= fun tree -> {ctxt with tree} -let add t key data = raw_add t (data_key key) data +let add ctxt key data = raw_add ctxt (data_key key) data -let raw_remove ctxt key = - Store.Tree.remove ctxt.tree key >>= fun tree -> Lwt.return {ctxt with tree} +let raw_remove ctxt k = + Tree.remove ctxt.tree k >|= fun tree -> {ctxt with tree} -let remove ctxt key = - Store.Tree.remove ctxt.tree (data_key key) - >>= fun tree -> Lwt.return {ctxt with tree} +let remove ctxt key = raw_remove ctxt (data_key key) -let copy ctxt ~from ~to_ = - Store.Tree.find_tree ctxt.tree (data_key from) - >>= function - | None -> - Lwt.return_none - | Some sub_tree -> - Store.Tree.add_tree ctxt.tree (data_key to_) sub_tree - >>= fun tree -> Lwt.return_some {ctxt with tree} +let find_tree ctxt key = Tree.find_tree ctxt.tree (data_key key) -type key_or_dir = [`Key of key | `Dir of key] +let add_tree ctxt key tree = + Tree.add_tree ctxt.tree (data_key key) tree >|= fun tree -> {ctxt with tree} -let fold ctxt key ~init ~f = - Store.Tree.find_tree ctxt.tree (data_key key) - >>= function - | None -> - Lwt.return init - | Some tree -> - Store.Tree.fold - ~depth:(`Eq 1) - ~contents:(fun k _ acc -> - if k = [] then Lwt.return acc else f (`Key (key @ k)) acc) - ~node:(fun k _ acc -> - assert (k <> []) ; - f (`Dir (key @ k)) acc) - tree - init +let fold ?depth ctxt key ~init ~f = + Tree.fold ?depth ctxt.tree (data_key key) ~init ~f (*-- Predefined Fields -------------------------------------------------------*) @@ -514,9 +601,7 @@ let add_predecessor_ops_metadata_hash v hash = let init ?patch_context ?mapsize:_ ?(readonly = false) root = Store.Repo.v (Irmin_pack.config ~readonly ?index_log_size:!index_log_size root) - >>= fun repo -> - let v = {path = root; repo; patch_context; readonly} in - Lwt.return v + >|= fun repo -> {path = root; repo; patch_context; readonly} let close index = Store.Repo.close index.repo @@ -933,9 +1018,9 @@ module Dumpable_context = struct | Some t -> Store.Tree.add_tree tree key (t :> tree) >>= Lwt.return_some - let add_string (Batch (_, t, _)) string = + let add_bytes (Batch (_, t, _)) b = (* Save the contents in the store *) - Store.save_contents t string >|= fun _ -> Store.Tree.of_contents string + Store.save_contents t b >|= fun _ -> Store.Tree.of_contents b let add_dir batch l = let rec fold_list sub_tree = function @@ -1021,9 +1106,9 @@ let validate_context_hash_consistency_and_commit ~data_hash Data_encoding.Binary.to_bytes_exn Test_chain_status.encoding test_chain in let tree = Store.Tree.empty in - Store.Tree.add tree current_protocol_key (Bytes.to_string protocol_value) + Store.Tree.add tree current_protocol_key protocol_value >>= fun tree -> - Store.Tree.add tree current_test_chain_key (Bytes.to_string test_chain_value) + Store.Tree.add tree current_test_chain_key test_chain_value >>= fun tree -> ( match predecessor_block_metadata_hash with | Some predecessor_block_metadata_hash -> @@ -1033,7 +1118,7 @@ let validate_context_hash_consistency_and_commit ~data_hash Store.Tree.add tree current_predecessor_block_metadata_hash_key - (Bytes.to_string predecessor_block_metadata_hash_value) + predecessor_block_metadata_hash_value | None -> Lwt.return tree ) >>= fun tree -> @@ -1046,7 +1131,7 @@ let validate_context_hash_consistency_and_commit ~data_hash Store.Tree.add tree current_predecessor_ops_metadata_hash_key - (Bytes.to_string predecessor_ops_metadata_hash_value) + predecessor_ops_metadata_hash_value | None -> Lwt.return tree ) >>= fun tree -> @@ -1054,7 +1139,7 @@ let validate_context_hash_consistency_and_commit ~data_hash Irmin.Info.v ~date:(Time.Protocol.to_seconds timestamp) ~author message in let data_tree = Store.Tree.shallow index.repo data_hash in - Store.Tree.add_tree tree ["data"] data_tree + Store.Tree.add_tree tree current_data_key data_tree >>= fun node -> let node = Store.Tree.hash node in let commit = P.Commit.Val.v ~parents ~node ~info in diff --git a/src/lib_storage/context.mli b/src/lib_storage/context.mli index 7d18ba1cc41e4f037e5961f890e138d03da9613f..6cbb95084a5e625e278d44e0c7319df9b7b4bc6d 100644 --- a/src/lib_storage/context.mli +++ b/src/lib_storage/context.mli @@ -28,14 +28,20 @@ (** Tezos - Versioned, block indexed (key x value) store *) -(** A block-indexed (key x value) store directory. *) -type index +(** {2 Generic interface} *) -(** A (key x value) store for a given block. *) -type t +module type S = sig + (** @inline *) + include Context_intf.S +end + +include S type context = t +(** A block-indexed (key x value) store directory. *) +type index + (** Open or initialize a versioned store at a given path. *) val init : ?patch_context:(context -> context tzresult Lwt.t) -> @@ -65,47 +71,6 @@ val commit_genesis : val commit_test_chain_genesis : context -> Block_header.t -> Block_header.t Lwt.t -(** {2 Generic interface} *) - -(** 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 - -(** [mem_tree t k] is like {!mem} but for trees. *) -val mem_tree : context -> key -> bool 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 - -(** [add t k v] is an Lwt promise that resolves to [c] such that: - - - [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 - -type key_or_dir = [`Key of key | `Dir of key] - -(** [fold] iterates over elements under a path (not recursive). - Elements are traversed in lexical order of keys. *) -val fold : - context -> key -> init:'a -> f:(key_or_dir -> 'a -> 'a Lwt.t) -> 'a Lwt.t - (** {2 Accessing and Updating Versions} *) (** [restore_integrity ppf index] attempts to restore the context diff --git a/src/lib_storage/context_dump.ml b/src/lib_storage/context_dump.ml index 9dda75c84cb5f0ca8dad3c140016e685284fb678..9aa1dd145299d5017bce2dfdd344077fec0e2de0 100644 --- a/src/lib_storage/context_dump.ml +++ b/src/lib_storage/context_dump.ml @@ -169,7 +169,7 @@ module Make (I : Dump_interface) = struct pred_ops_metadata_hashes : Operation_metadata_hash.t list list option; } | Node of (string * I.hash) list - | Blob of string + | Blob of bytes | Proot of I.Pruned_block.t | Loot of I.Protocol_data.t | End @@ -181,9 +181,9 @@ module Make (I : Dump_interface) = struct case ~title:"blob" (Tag (Char.code 'b')) - string - (function Blob string -> Some string | _ -> None) - (function string -> Blob string) + bytes + (function Blob b -> Some b | _ -> None) + (function b -> Blob b) let node_encoding = let open Data_encoding in @@ -566,7 +566,7 @@ module Make (I : Dump_interface) = struct let read = ref 0 in let rbuf = ref (fd, Bytes.empty, 0, read) in (* Editing the repository *) - let add_blob t blob = I.add_string t blob >>= fun tree -> return tree in + let add_blob t blob = I.add_bytes t blob >>= fun tree -> return tree in let add_dir t keys = I.add_dir t keys >>= function diff --git a/src/lib_storage/context_dump_intf.ml b/src/lib_storage/context_dump_intf.ml index 8a301aab21282fa8af59d4c15aeb7fb207d207e1..b001923fae6c0a6cb0ca3ce2ec1018a515ea6538 100644 --- a/src/lib_storage/context_dump_intf.ml +++ b/src/lib_storage/context_dump_intf.ml @@ -35,7 +35,7 @@ module type Dump_interface = sig type hash - type contents := string + type contents := bytes type step := string @@ -141,7 +141,7 @@ module type Dump_interface = sig val update_context : context -> tree -> context - val add_string : batch -> string -> tree Lwt.t + val add_bytes : batch -> bytes -> tree Lwt.t val add_dir : batch -> (step * hash) list -> tree option Lwt.t end diff --git a/src/lib_storage/context_intf.ml b/src/lib_storage/context_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..554aab226342966ec70b20f80df952fd70597a3e --- /dev/null +++ b/src/lib_storage/context_intf.ml @@ -0,0 +1,177 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018-2021 Tarides *) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +module type VIEW = sig + (** The type for context views. *) + type t + + (** The type for context keys. *) + type key + + (** The type for context values. *) + type value + + (** The type for context trees. *) + type tree + + (** {2 Getters} *) + + (** [mem t k] is an Lwt promise that resolves to [true] iff [k] is bound + to a value in [t]. *) + val mem : t -> key -> bool Lwt.t + + (** [mem_tree t k] is like {!mem} but for trees. *) + val mem_tree : t -> key -> bool Lwt.t + + (** [find t k] is an Lwt promise that resolves to [Some v] if [k] is + bound to the value [v] in [t] and [None] otherwise. *) + val find : t -> key -> value option Lwt.t + + (** [find_tree t k] is like {!find} but for trees. *) + val find_tree : t -> key -> tree option Lwt.t + + (** [list t key] is the list of files and sub-nodes stored under [k] in [t]. + The result order is not specified but is stable. + + [offset] and [length] are used for pagination. *) + val list : + t -> ?offset:int -> ?length:int -> key -> (string * tree) list Lwt.t + + (** {2 Setters} *) + + (** [add t k v] is an Lwt promise that resolves to [c] such that: + + - [k] is bound to [v] in [c]; + - and [c] is similar to [t] otherwise. + + If [k] was already bound in [t] to a value that is physically equal + to [v], the result of the function is a promise that resolves to + [t]. Otherwise, the previous binding of [k] in [t] disappears. *) + val add : t -> key -> value -> t Lwt.t + + (** [add_tree] is like {!add} but for trees. *) + val add_tree : t -> key -> tree -> 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 : t -> key -> t Lwt.t + + (** {2 Folding} *) + + (** [fold ?depth t root ~init ~f] recursively folds over the trees + and values of [t]. The [f] callbacks are called with a key relative + to [root]. [f] is never called with an empty key for values; i.e., + folding over a value is a no-op. + + Elements are traversed in lexical order of keys. + + The depth is 0-indexed. If [depth] is set (by default it is not), then [f] + is only called when the conditions described by the parameter is true: + + - [Eq d] folds over nodes and contents of depth exactly [d]. + - [Lt d] folds over nodes and contents of depth strictly less than [d]. + - [Le d] folds over nodes and contents of depth less than or equal to [d]. + - [Gt d] folds over nodes and contents of depth strictly more than [d]. + - [Ge d] folds over nodes and contents of depth more than or equal to [d]. *) + val fold : + ?depth:[`Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int] -> + t -> + key -> + init:'a -> + f:(key -> tree -> 'a -> 'a Lwt.t) -> + 'a Lwt.t +end + +module type TREE = sig + (** [Tree] provides immutable, in-memory partial mirror of the + context, with lazy reads and delayed writes. The trees are Merkle + trees that carry the same hash as the part of the context they + mirror. + + Trees are immutable and non-persistent (they disappear if the + host crash), held in memory for efficiency, where reads are done + lazily and writes are done only when needed, e.g. on + [Context.commit]. If a key is modified twice, only the last + value will be written to disk on commit. *) + + (** The type for context views. *) + type t + + (** The type for context trees. *) + type tree + + (** [empty _] is the empty tree. *) + val empty : t -> tree + + (** [is_empty t] is true iff [t] is [empty _]. *) + val is_empty : tree -> bool + + (** [kind t] is [t]'s kind. It's either a tree node or a leaf + value. *) + val kind : tree -> [`Value of bytes | `Tree] + + (** [hash t] is [t]'s Merkle hash. *) + val hash : tree -> Context_hash.t + + (** [equal x y] is true iff [x] and [y] have the same Merkle hash. *) + val equal : tree -> tree -> bool + + include VIEW with type t := tree and type tree := tree + + (** {2 Data Encoding} *) + + (** The type for in-memory, raw contexts. *) + type raw = [`Value of bytes | `Tree of raw TzString.Map.t] + + (** [raw_encoding] is the data encoding for raw trees. *) + val raw_encoding : raw Data_encoding.t + + (** [to_raw t] is an Lwt promise that resolves to a raw tree + equivalent to [t]. *) + val to_raw : tree -> raw Lwt.t + + (** [of_raw t] is the tree equivalent to the raw tree [t]. *) + val of_raw : raw -> tree + + (** {2 Caches} *) + + (** [clear ?depth t] clears all caches in the tree [t] for subtrees with a + depth higher than [depth]. If [depth] is not set, all of the subtrees are + cleared. *) + val clear : ?depth:int -> tree -> unit +end + +module type S = sig + include VIEW with type key = string list and type value = bytes + + module Tree : + TREE + with type t := t + and type key := key + and type value := value + and type tree := tree +end diff --git a/src/lib_storage/test/assert.ml b/src/lib_storage/test/assert.ml index 09cfd761d830a47927122fb30045482b00008e3e..f644002686b4c2aec339cee0de9a5a0868a98c79 100644 --- a/src/lib_storage/test/assert.ml +++ b/src/lib_storage/test/assert.ml @@ -46,6 +46,12 @@ let equal_string_option ?msg o1 o2 = let is_none ?(msg = "") x = if x <> None then fail "None" "Some _" msg +let equal_bytes_option ?msg o1 o2 = + let prn = function None -> "None" | Some s -> Bytes.to_string s in + equal ?msg ~prn o1 o2 + +let equal_bool ?msg b1 b2 = equal ?msg ~prn:(fun s -> string_of_bool s) b1 b2 + let make_equal_list eq prn ?(msg = "") x y = let rec iter i x y = match (x, y) with @@ -55,7 +61,15 @@ let make_equal_list eq prn ?(msg = "") x y = let fm = Printf.sprintf "%s (at index %d)" msg i in fail (prn hd_x) (prn hd_y) fm | (_ :: _, []) | ([], _ :: _) -> - let fm = Printf.sprintf "%s (lists of different sizes)" msg in + let fm = + Fmt.str + "%s (lists of different sizes: %a vs. %a)" + msg + Fmt.(Dump.list string) + (List.map prn x) + Fmt.(Dump.list string) + (List.map prn y) + in fail_msg "%s" fm | ([], []) -> () @@ -89,3 +103,20 @@ let equal_key_dir_list ?msg l1 l2 = let equal_context_hash_list ?msg l1 l2 = let pr_persist hash = Printf.sprintf "[%s]" @@ Context_hash.to_string hash in make_equal_list ?msg Context_hash.( = ) pr_persist l1 l2 + +let equal_raw_tree ?(msg = "") r1 r2 = + let rec aux r1 r2 = + match (r1, r2) with + | (`Value v1, `Value v2) -> + equal_string ~msg (Bytes.to_string v1) (Bytes.to_string v2) ; + true + | (`Tree t1, `Tree t2) -> + if not (TzString.Map.equal aux t1 t2) then fail "" "" msg ; + true + | (`Tree _, `Value v) -> + fail "" (Bytes.to_string v) msg + | (`Value v, `Tree _) -> + fail "" (Bytes.to_string v) msg + in + let (_ : bool) = aux r1 r2 in + () diff --git a/src/lib_storage/test/test_context.ml b/src/lib_storage/test/test_context.ml index ead214dca809ad34d9b2de2a6c295f6e896aa8dc..5643e5ee1530a90e27f33fce55fe0a7df51247c6 100644 --- a/src/lib_storage/test/test_context.ml +++ b/src/lib_storage/test/test_context.ml @@ -38,8 +38,6 @@ let ( >>=! ) x f = | Ok x -> f x -let ( >|= ) = Lwt.( >|= ) - open Filename.Infix (** Basic blocks *) @@ -60,10 +58,6 @@ let chain_id = Chain_id.of_block_hash genesis_block let commit = commit ~time:Time.Protocol.epoch ~message:"" -let block2 = - Block_hash.of_hex_exn - (`Hex "2222222222222222222222222222222222222222222222222222222222222222") - let create_block2 idx genesis_commit = checkout idx genesis_commit >>= function @@ -76,10 +70,6 @@ let create_block2 idx genesis_commit = >>= fun ctxt -> add ctxt ["version"] (Bytes.of_string "0.0") >>= fun ctxt -> commit ctxt -let block3a = - Block_hash.of_hex_exn - (`Hex "3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a") - let create_block3a idx block2_commit = checkout idx block2_commit >>= function @@ -90,14 +80,6 @@ let create_block3a idx block2_commit = >>= fun ctxt -> add ctxt ["a"; "d"] (Bytes.of_string "Mars") >>= fun ctxt -> commit ctxt -let block3b = - Block_hash.of_hex_exn - (`Hex "3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b") - -let block3c = - Block_hash.of_hex_exn - (`Hex "3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c") - let create_block3b idx block2_commit = checkout idx block2_commit >>= function @@ -156,6 +138,18 @@ let test_simple {idx; block2; _} = Assert.equal_string_option ~msg:__LOC__ (Some "Juin") (c juin) ; Lwt.return_unit +let test_list {idx; block2; _} = + checkout idx block2 + >>= function + | None -> + Assert.fail_msg "checkout block2" + | Some ctxt -> + list ctxt ["a"] + >>= fun ls -> + let ls = List.sort compare (List.map fst ls) in + Assert.equal_string_list ~msg:__LOC__ ["b"; "c"] ls ; + Lwt.return_unit + let test_continuation {idx; block3a; _} = checkout idx block3a >>= function @@ -231,17 +225,16 @@ let test_replay {idx; genesis; _} = Assert.equal_string_option ~msg:__LOC__ (Some "Juillet") (c juillet) ; Lwt.return_unit -let fold_keys s k ~init ~f = - let rec loop k acc = - fold s k ~init:acc ~f:(fun file acc -> - match file with `Key k -> f k acc | `Dir k -> loop k acc) - in - loop k init +let fold_keys s root ~init ~f = + fold s root ~init ~f:(fun k v acc -> + match Tree.kind v with + | `Value _ -> + f (root @ k) acc + | `Tree -> + Lwt.return acc) let keys t = fold_keys t ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc)) -let compare_key (x, _) (y, _) = String.compare x y - let steps = ["00"; "01"; "02"; "03"; "05"; "06"; "07"; "09"; "0a"; "0b"; "0c"; "0e"; "0f"; "10"; "11"; "12"; "13"; "14"; "15"; "16"; "17"; "19"; @@ -267,7 +260,7 @@ let bindings = let zero = Bytes.make 10 '0' in List.map (fun x -> (["root"; x], zero)) steps -let test_fold {idx; genesis; _} = +let test_fold_keys {idx; genesis; _} = checkout idx genesis >>= function | None -> @@ -316,6 +309,154 @@ let test_fold {idx; genesis; _} = Assert.equal_string_list_list ~msg:__LOC__ (List.map fst bindings) bs ; Lwt.return_unit +let test_fold {idx; genesis; _} = + checkout idx genesis + >>= function + | None -> + Assert.fail_msg "checkout genesis_block" + | Some ctxt -> + let foo1 = Bytes.of_string "foo1" in + let foo2 = Bytes.of_string "foo2" in + add ctxt ["foo"; "toto"] foo1 + >>= fun ctxt -> + add ctxt ["foo"; "bar"; "toto"] foo2 + >>= fun ctxt -> + let fold depth ecs ens = + fold ?depth ctxt [] ~init:([], []) ~f:(fun path t (cs, ns) -> + match Tree.kind t with + | `Tree -> + Lwt.return (cs, path :: ns) + | `Value _ -> + Lwt.return (path :: cs, ns)) + >>= fun (cs, ns) -> + Assert.equal_string_list_list ~msg:__LOC__ ecs cs ; + Assert.equal_string_list_list ~msg:__LOC__ ens ns ; + Lwt.return () + in + fold + None + [["foo"; "toto"]; ["foo"; "bar"; "toto"]] + [["foo"; "bar"]; ["foo"]; []] + >>= fun () -> + fold (Some (`Eq 0)) [] [[]] + >>= fun () -> + fold (Some (`Eq 1)) [] [["foo"]] + >>= fun () -> + fold (Some (`Eq 2)) [["foo"; "toto"]] [["foo"; "bar"]] + >>= fun () -> + fold (Some (`Lt 2)) [] [["foo"]; []] + >>= fun () -> + fold (Some (`Le 2)) [["foo"; "toto"]] [["foo"; "bar"]; ["foo"]; []] + >>= fun () -> + fold + (Some (`Ge 2)) + [["foo"; "toto"]; ["foo"; "bar"; "toto"]] + [["foo"; "bar"]] + >>= fun () -> fold (Some (`Gt 2)) [["foo"; "bar"; "toto"]] [] + +let test_trees {idx; genesis; _} = + checkout idx genesis + >>= function + | None -> + Assert.fail_msg "checkout genesis_block" + | Some ctxt -> + Tree.fold ~depth:(`Eq 1) ~init:() (Tree.empty ctxt) [] ~f:(fun k _ () -> + assert (List.length k = 1) ; + Assert.fail_msg "empty") + >>= fun () -> + let foo1 = Bytes.of_string "foo1" in + let foo2 = Bytes.of_string "foo2" in + Tree.empty ctxt + |> fun v1 -> + Tree.add v1 ["foo"; "toto"] foo1 + >>= fun v1 -> + Tree.add v1 ["foo"; "bar"; "toto"] foo2 + >>= fun v1 -> + let fold depth ecs ens = + Tree.fold v1 ?depth [] ~init:([], []) ~f:(fun path t (cs, ns) -> + match Tree.kind t with + | `Tree -> + Lwt.return (cs, path :: ns) + | `Value _ -> + Lwt.return (path :: cs, ns)) + >>= fun (cs, ns) -> + Assert.equal_string_list_list ~msg:__LOC__ ecs cs ; + Assert.equal_string_list_list ~msg:__LOC__ ens ns ; + Lwt.return () + in + fold + None + [["foo"; "toto"]; ["foo"; "bar"; "toto"]] + [["foo"; "bar"]; ["foo"]; []] + >>= fun () -> + fold (Some (`Eq 0)) [] [[]] + >>= fun () -> + fold (Some (`Eq 1)) [] [["foo"]] + >>= fun () -> + fold (Some (`Eq 2)) [["foo"; "toto"]] [["foo"; "bar"]] + >>= fun () -> + fold (Some (`Lt 2)) [] [["foo"]; []] + >>= fun () -> + fold (Some (`Le 2)) [["foo"; "toto"]] [["foo"; "bar"]; ["foo"]; []] + >>= fun () -> + fold + (Some (`Ge 2)) + [["foo"; "toto"]; ["foo"; "bar"; "toto"]] + [["foo"; "bar"]] + >>= fun () -> + fold (Some (`Gt 2)) [["foo"; "bar"; "toto"]] [] + >>= fun () -> + Tree.remove v1 ["foo"; "bar"; "toto"] + >>= fun v1 -> + Tree.find v1 ["foo"; "bar"; "toto"] + >>= fun v -> + Assert.equal_bytes_option ~msg:__LOC__ None v ; + Tree.find v1 ["foo"; "toto"] + >>= fun v -> + Assert.equal_bytes_option ~msg:__LOC__ (Some foo1) v ; + Tree.empty ctxt + |> fun v1 -> + Tree.add v1 ["foo"; "1"] foo1 + >>= fun v1 -> + Tree.add v1 ["foo"; "2"] foo2 + >>= fun v1 -> + Tree.remove v1 ["foo"; "1"] + >>= fun v1 -> + Tree.remove v1 ["foo"; "2"] + >>= fun v1 -> + Tree.find v1 ["foo"; "1"] + >>= fun v -> + Assert.equal_bytes_option ~msg:__LOC__ None v ; + Tree.remove v1 [] + >>= fun v1 -> + Assert.equal_bool ~msg:__LOC__ true (Tree.is_empty v1) ; + Lwt.return () + +let test_raw {idx; genesis; _} = + checkout idx genesis + >>= function + | None -> + Assert.fail_msg "checkout genesis_block" + | Some ctxt -> + let foo1 = Bytes.of_string "foo1" in + let foo2 = Bytes.of_string "foo2" in + add ctxt ["foo"; "toto"] foo1 + >>= fun ctxt -> + add ctxt ["foo"; "bar"; "toto"] foo2 + >>= fun ctxt -> + find_tree ctxt [] + >>= fun tree -> + let tree = Option.get tree in + Tree.to_raw tree + >>= fun raw -> + let a = TzString.Map.singleton "toto" (`Value foo1) in + let b = TzString.Map.singleton "toto" (`Value foo2) in + let c = TzString.Map.add "bar" (`Tree b) a in + let d = TzString.Map.singleton "foo" (`Tree c) in + let e = `Tree d in + Assert.equal_raw_tree ~msg:__LOC__ e raw ; + Lwt.return () + let test_dump {idx; block3b; _} = Lwt_utils_unix.with_tempdir "tezos_test_" (fun base_dir2 -> let dumpfile = base_dir2 // "dump" in @@ -385,10 +526,14 @@ let test_dump {idx; block3b; _} = let tests : (string * (t -> unit Lwt.t)) list = [ ("simple", test_simple); + ("list", test_list); ("continuation", test_continuation); ("fork", test_fork); ("replay", test_replay); + ("fold_keys", test_fold_keys); ("fold", test_fold); + ("trees", test_trees); + ("raw", test_raw); ("dump", test_dump) ] let tests = diff --git a/src/lib_storage/test/test_context.mli b/src/lib_storage/test/test_context.mli new file mode 100644 index 0000000000000000000000000000000000000000..c938c9217a49b725e2cdc5b2fe40fc94647df614 --- /dev/null +++ b/src/lib_storage/test/test_context.mli @@ -0,0 +1,26 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +val tests : unit Alcotest_lwt.test_case list