From 3b379ac98dba42980a299d3d501d608f20137750 Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Wed, 9 Nov 2022 22:16:19 +0100 Subject: [PATCH 01/11] Layer2/Store: indexed store functors --- manifest/main.ml | 3 + opam/tezos-layer2-store.opam | 3 + src/lib_layer2_store/dune | 6 +- src/lib_layer2_store/indexed_store.ml | 514 +++++++++++++++++++++++++ src/lib_layer2_store/indexed_store.mli | 185 +++++++++ 5 files changed, 710 insertions(+), 1 deletion(-) create mode 100644 src/lib_layer2_store/indexed_store.ml create mode 100644 src/lib_layer2_store/indexed_store.mli diff --git a/manifest/main.ml b/manifest/main.ml index e0fd02bd9b0c..a09185366d7c 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -3183,10 +3183,13 @@ let octez_layer2_store = ~synopsis:"Tezos: layer2 storage utils" ~deps: [ + index; octez_base |> open_ ~m:"TzPervasives"; irmin_pack; irmin_pack_unix; irmin; + aches_lwt; + octez_stdlib_unix |> open_; octez_context_encoding; ] ~linkall:true diff --git a/opam/tezos-layer2-store.opam b/opam/tezos-layer2-store.opam index a2c30c9ad19a..10d8e511d3d9 100644 --- a/opam/tezos-layer2-store.opam +++ b/opam/tezos-layer2-store.opam @@ -9,9 +9,12 @@ dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ "dune" { >= "3.0" } + "index" { >= "1.6.0" & < "1.7.0" } "tezos-base" "irmin-pack" { >= "3.5.1" & < "3.6.0" } "irmin" { >= "3.5.1" & < "3.6.0" } + "aches-lwt" { >= "1.0.0" } + "tezos-stdlib-unix" "tezos-context" ] build: [ diff --git a/src/lib_layer2_store/dune b/src/lib_layer2_store/dune index 301e0e241453..70f9934f1492 100644 --- a/src/lib_layer2_store/dune +++ b/src/lib_layer2_store/dune @@ -6,12 +6,16 @@ (package tezos-layer2-store) (instrumentation (backend bisect_ppx)) (libraries + index tezos-base irmin-pack irmin-pack.unix irmin + aches-lwt + tezos-stdlib-unix tezos-context.encoding) (library_flags (:standard -linkall)) (flags (:standard) - -open Tezos_base.TzPervasives)) + -open Tezos_base.TzPervasives + -open Tezos_stdlib_unix)) diff --git a/src/lib_layer2_store/indexed_store.ml b/src/lib_layer2_store/indexed_store.ml new file mode 100644 index 000000000000..c453413d72b9 --- /dev/null +++ b/src/lib_layer2_store/indexed_store.ml @@ -0,0 +1,514 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2023 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 Store_sigs + +type error += Cannot_encode_data of string + +let () = + register_error_kind + ~id:"layer2_store.cannot_encode_data" + ~title:"Data cannot be encoded" + ~description:"Data cannot be encoded to be stored on disk." + ~pp:(fun ppf name -> + Format.fprintf ppf "Data %s cannot be encoded to be stored on disk." name) + `Permanent + Data_encoding.(obj1 (req "name" string)) + (function Cannot_encode_data n -> Some n | _ -> None) + (fun n -> Cannot_encode_data n) + +type error += Cannot_write_file of string + +let () = + register_error_kind + ~id:"layer2_store.cannot_write_file" + ~title:"File cannot be written" + ~description:"File cannot be written to disk." + ~pp:(fun ppf name -> + Format.fprintf ppf "File %s cannot be written to disk." name) + `Permanent + Data_encoding.(obj1 (req "name" string)) + (function Cannot_write_file n -> Some n | _ -> None) + (fun n -> Cannot_write_file n) + +(* Helper functions to copy byte sequences or integers in [src] to another byte + sequence [dst] at offset [offset], with named arguments to avoid + confusion. These functions return the offset in the destination at which to + copy the more data. *) + +let blit ~src ~dst offset = + let len = Bytes.length src in + Bytes.blit src 0 dst offset len ; + offset + len + +let bytes_set_int64 ~src ~dst offset = + Bytes.set_int64_be dst offset src ; + offset + 8 + +let bytes_set_int8 ~src ~dst offset = + Bytes.set_int8 dst offset src ; + offset + 1 + +(* Helper functions to read data (strings with a decoding function, or integers) + from a binary string. These functions return, as the second component, the + offset in the string at which to read more data. *) + +let read_int64 str offset = + let i = TzEndian.get_int64_string str offset in + (i, offset + 8) + +let read_int8 str offset = + let i = TzEndian.get_int8_string str offset in + (i, offset + 1) + +(* Functors to build stores on indexes *) + +module type SINGLETON_STORE = sig + type +'a t + + type value + + val init : path:string -> 'a mode -> 'a t Lwt.t + + val read : [> `Read] t -> value option Lwt.t + + val write : [> `Write] t -> value -> unit tzresult Lwt.t + + val delete : [> `Write] t -> unit Lwt.t +end + +module type INDEXABLE_STORE = sig + type +'a t + + type key + + type value + + val init : path:string -> 'a mode -> 'a t Lwt.t + + val mem : [> `Read] t -> key -> bool Lwt.t + + val find : [> `Read] t -> key -> value option Lwt.t + + val add : ?flush:bool -> [> `Write] t -> key -> value -> unit Lwt.t + + val close : _ t -> unit Lwt.t +end + +module type INDEXABLE_REMOVABLE_STORE = sig + include INDEXABLE_STORE + + val remove : ?flush:bool -> [> `Write] t -> key -> unit Lwt.t +end + +module type INDEXED_FILE = sig + type +'a t + + type key + + type header + + type value + + val mem : [> `Read] t -> key -> bool Lwt.t + + val header : [> `Read] t -> key -> header option Lwt.t + + val read : [> `Read] t -> key -> value option Lwt.t + + val append : + ?flush:bool -> [> `Write] t -> key:key -> value:value -> unit Lwt.t + + val init : data_dir:string -> cache_size:int -> 'a mode -> 'a t Lwt.t + + val close : _ t -> unit Lwt.t +end + +module type ENCODABLE_VALUE = sig + type t + + val name : string + + val encoding : t Data_encoding.t +end + +module type FIXED_ENCODABLE_VALUE = sig + include ENCODABLE_VALUE + + val fixed_size : int +end + +module type ENCODABLE_VALUE_HEADER = sig + include ENCODABLE_VALUE + + module Header : FIXED_ENCODABLE_VALUE + + val header : t -> Header.t +end + +module Make_fixed_encodable (V : ENCODABLE_VALUE) : + FIXED_ENCODABLE_VALUE with type t = V.t = struct + include V + + let fixed_size = + match Data_encoding.Binary.fixed_length encoding with + | None -> Stdlib.invalid_arg (name ^ " encoding is not fixed size") + | Some size -> size +end + +module Make_index_value (E : FIXED_ENCODABLE_VALUE) : + Index.Value.S with type t = E.t = struct + type t = E.t + + let encoded_size = E.fixed_size + + let encode v = + Data_encoding.Binary.to_string_exn ~buffer_size:encoded_size E.encoding v + + let decode buf offset = + let _read_bytes, v = + Data_encoding.Binary.read_exn E.encoding buf offset encoded_size + in + v + + (* The {!Repr.t} value is only used for pretty printing in {!Index} so this is + fine. *) + let t = Repr.map Repr.string (fun s -> decode s 0) encode +end + +module Make_index_key (E : sig + include FIXED_ENCODABLE_VALUE + + val equal : t -> t -> bool +end) : Index.Key.S with type t = E.t = struct + include Make_index_value (E) + + let equal = E.equal + + let hash v = Stdlib.Hashtbl.hash (encode v) + + (* {!Stdlib.Hashtbl.hash} is 30 bits *) + let hash_size = 30 (* in bits *) +end + +module Make_indexable (K : Index.Key.S) (V : Index.Value.S) = struct + module I = Index_unix.Make (K) (V) (Index.Cache.Unbounded) + + type _ t = {index : I.t; scheduler : Lwt_idle_waiter.t} + + (* TODO: https://gitlab.com/tezos/tezos/-/issues/4654 + Make log size constant configurable. *) + let log_size = 10_000 + + let mem store k = + Lwt_idle_waiter.task store.scheduler @@ fun () -> + Lwt.return (I.mem store.index k) + + let find store k = + let open Lwt_syntax in + Lwt_idle_waiter.task store.scheduler @@ fun () -> + Option.catch_os @@ fun () -> + let v = I.find store.index k in + return_some v + + let add ?(flush = true) store k v = + Lwt_idle_waiter.force_idle store.scheduler @@ fun () -> + I.replace store.index k v ; + if flush then I.flush store.index ; + Lwt.return_unit + + let init (type a) ~path (mode : a mode) : a t Lwt.t = + let readonly = match mode with Read_only -> true | Read_write -> false in + let index = I.v ~log_size ~readonly path in + let scheduler = Lwt_idle_waiter.create () in + Lwt.return {index; scheduler} + + let close store = + Lwt_idle_waiter.force_idle store.scheduler @@ fun () -> + (try I.close store.index with Index.Closed -> ()) ; + Lwt.return_unit +end + +module Make_indexable_removable (K : Index.Key.S) (V : Index.Value.S) = struct + module V_opt = struct + (* The values stored in the index are optional values. When we "remove" a + key from the store, we're not really removing it from the index, but + simply setting its association to [None] (encoded with zero bytes here). + *) + + type t = V.t option + + let t = Repr.option V.t + + let encoded_size = 1 + V.encoded_size + + let encode v = + let dst = Bytes.create encoded_size in + let tag, value_bytes = + match v with + | None -> (0, Bytes.make V.encoded_size '\000') + | Some v -> (1, V.encode v |> Bytes.unsafe_of_string) + in + let offset = bytes_set_int8 ~dst ~src:tag 0 in + let _ = blit ~src:value_bytes ~dst offset in + Bytes.unsafe_to_string dst + + let decode str offset = + let tag, offset = read_int8 str offset in + match tag with + | 0 -> None + | 1 -> + let value = V.decode str offset in + Some value + | _ -> assert false + end + + include Make_indexable (K) (V_opt) + + let find store k = + let open Lwt_syntax in + let+ v = find store k in + match v with None | Some None -> None | Some (Some v) -> Some v + + let mem store hash = + let open Lwt_syntax in + let+ b = find store hash in + Option.is_some b + + let add ?flush store k v = add ?flush store k (Some v) + + let remove ?(flush = true) store k = + Lwt_idle_waiter.force_idle store.scheduler @@ fun () -> + let exists = I.mem store.index k in + if not exists then Lwt.return_unit + else ( + I.replace store.index k None ; + if flush then I.flush store.index ; + Lwt.return_unit) +end + +module Make_singleton (S : sig + type t + + val name : string + + val encoding : t Data_encoding.t +end) : SINGLETON_STORE with type value := S.t = struct + type 'a t = {file : string} + + let read store = + let open Lwt_syntax in + let* exists = Lwt_unix.file_exists store.file in + match exists with + | false -> return_none + | true -> + Lwt_io.with_file + ~flags:[Unix.O_RDONLY; O_CLOEXEC] + ~mode:Input + store.file + @@ fun channel -> + let+ bytes = Lwt_io.read channel in + Data_encoding.Binary.of_bytes_opt + S.encoding + (Bytes.unsafe_of_string bytes) + + let write store x = + let open Lwt_result_syntax in + let*! res = + Lwt_utils_unix.with_atomic_open_out ~overwrite:true store.file + @@ fun fd -> + let* block_bytes = + match Data_encoding.Binary.to_bytes_opt S.encoding x with + | None -> tzfail (Cannot_encode_data S.name) + | Some bytes -> return bytes + in + let*! () = Lwt_utils_unix.write_bytes fd block_bytes in + return_unit + in + match res with + | Ok res -> Lwt.return res + | Error _ -> tzfail (Cannot_write_file S.name) + + let delete store = + let open Lwt_syntax in + let* exists = Lwt_unix.file_exists store.file in + match exists with + | false -> return_unit + | true -> Lwt_unix.unlink store.file + + let init ~path _mode = Lwt.return {file = path} +end + +module Make_indexed_file (K : Index.Key.S) (V : ENCODABLE_VALUE_HEADER) = struct + module Cache = + Aches_lwt.Lache.Make_option (Aches.Rache.Transfer (Aches.Rache.LRU) (K)) + module Raw_header = Make_index_value (V.Header) + + module IHeader = struct + type t = {offset : int; header : V.Header.t} + + let encoded_size = 8 (* offset *) + Raw_header.encoded_size + + let t = + let open Repr in + map + (pair int Raw_header.t) + (fun (offset, header) -> {offset; header}) + (fun {offset; header} -> (offset, header)) + + let encode v = + let dst = Bytes.create encoded_size in + let offset = bytes_set_int64 ~src:(Int64.of_int v.offset) ~dst 0 in + let _offset = + blit ~src:(Raw_header.encode v.header |> String.to_bytes) ~dst offset + in + Bytes.unsafe_to_string dst + + let decode str offset = + let file_offset, offset = read_int64 str offset in + let header = Raw_header.decode str offset in + {offset = Int64.to_int file_offset; header} + end + + module Header_index = Index_unix.Make (K) (IHeader) (Index.Cache.Unbounded) + + module Values_file = struct + let encoding = Data_encoding.dynamic_size ~kind:`Uint30 V.encoding + + let pread_value_exn fd ~file_offset = + let open Lwt_syntax in + (* Read length *) + let length_bytes = Bytes.create 4 in + let* () = + Lwt_utils_unix.read_bytes ~file_offset ~pos:0 ~len:4 fd length_bytes + in + let value_length_int32 = Bytes.get_int32_be length_bytes 0 in + let value_length = Int32.to_int value_length_int32 in + let value_bytes = Bytes.extend length_bytes 0 value_length in + let* () = + Lwt_utils_unix.read_bytes + ~file_offset:(file_offset + 4) + ~pos:4 + ~len:value_length + fd + value_bytes + in + Lwt.return + ( Data_encoding.Binary.of_bytes_exn encoding value_bytes, + 4 + value_length ) + + let pread_value fd ~file_offset = + Option.catch_s (fun () -> pread_value_exn fd ~file_offset) + end + + type +'a t = { + index : Header_index.t; + fd : Lwt_unix.file_descr; + scheduler : Lwt_idle_waiter.t; + cache : V.t Cache.t; + } + + (* The log_size corresponds to the maximum size of the memory zone + allocated in memory before flushing it onto the disk. It is + basically a cache which is use for the index. The cache size is + `log_size * log_entry` where a `log_entry` is roughly 56 bytes. *) + (* TODO: https://gitlab.com/tezos/tezos/-/issues/4654 + Make log size constant configurable. *) + let blocks_log_size = 10_000 + + let mem store key = + Lwt_idle_waiter.task store.scheduler @@ fun () -> + Lwt.return (Header_index.mem store.index key) + + let header store key = + Lwt_idle_waiter.task store.scheduler @@ fun () -> + try + let {IHeader.header; _} = Header_index.find store.index key in + Lwt.return_some header + with Not_found -> Lwt.return_none + + let read store key = + let open Lwt_syntax in + Lwt_idle_waiter.task store.scheduler @@ fun () -> + Option.catch_os @@ fun () -> + let read_from_disk key = + let {IHeader.offset; _} = Header_index.find store.index key in + let* o = Values_file.pread_value store.fd ~file_offset:offset in + match o with + | Some (value, _) -> Lwt.return_some value + | None -> Lwt.return_none + in + Cache.bind_or_put store.cache key read_from_disk Lwt.return + + let locked_write_value store ~offset ~value ~key = + let open Lwt_syntax in + let value_bytes = + Data_encoding.Binary.to_bytes_exn Values_file.encoding value + in + let value_length = Bytes.length value_bytes in + let* () = + Lwt_utils_unix.write_bytes ~pos:0 ~len:value_length store.fd value_bytes + in + Header_index.replace store.index key {offset; header = V.header value} ; + return value_length + + let append ?(flush = true) store ~key ~(value : V.t) = + let open Lwt_syntax in + Lwt_idle_waiter.force_idle store.scheduler @@ fun () -> + Cache.put store.cache key (return_some value) ; + let* offset = Lwt_unix.lseek store.fd 0 Unix.SEEK_END in + let* _written_len = locked_write_value store ~offset ~value ~key in + if flush then Header_index.flush store.index ; + Lwt.return_unit + + let init (type a) ~data_dir ~cache_size (mode : a mode) : a t Lwt.t = + let open Lwt_syntax in + let readonly = match mode with Read_only -> true | Read_write -> false in + let flag, perms = + if readonly then (Unix.O_RDONLY, 0o444) else (Unix.O_RDWR, 0o644) + in + let* fd = + Lwt_unix.openfile + (Filename.concat data_dir "data") + [Unix.O_CREAT; O_CLOEXEC; flag] + perms + in + let index = + Header_index.v + ~log_size:blocks_log_size + ~readonly + (Filename.concat data_dir "index") + in + let scheduler = Lwt_idle_waiter.create () in + let cache = Cache.create cache_size in + Lwt.return {index; fd; scheduler; cache} + + let close store = + let open Lwt_syntax in + Lwt_idle_waiter.force_idle store.scheduler @@ fun () -> + (try Header_index.close store.index with Index.Closed -> ()) ; + let* _ignore = Lwt_utils_unix.safe_close store.fd in + Lwt.return_unit +end diff --git a/src/lib_layer2_store/indexed_store.mli b/src/lib_layer2_store/indexed_store.mli new file mode 100644 index 000000000000..650801c3240f --- /dev/null +++ b/src/lib_layer2_store/indexed_store.mli @@ -0,0 +1,185 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2023 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. *) +(* *) +(*****************************************************************************) + +(** Describes the different representations that can be stored persistently. *) + +open Store_sigs + +(** {2 Signatures} *) + +(** A store composed of a single file on disk *) +module type SINGLETON_STORE = sig + (** The type of the singleton store. *) + type +'a t + + (** The type of values stored in this singleton store. *) + type value + + (** Initializes a singleton store in the file [path]. *) + val init : path:string -> 'a mode -> 'a t Lwt.t + + (** Reads the current value from the disk. Returns [None] if the + file does not exist or if it is corrupted. *) + val read : [> `Read] t -> value option Lwt.t + + (** Write the value to disk. *) + val write : [> `Write] t -> value -> unit tzresult Lwt.t + + (** Deletes the value from the disk. *) + val delete : [> `Write] t -> unit Lwt.t +end + +(** An index store mapping keys to values. It is composed of an index only. *) +module type INDEXABLE_STORE = sig + (** The type of store build in indexes *) + type +'a t + + (** The type of keys for the *) + type key + + (** The type of values stored in the index *) + type value + + (** Initializes a store in the file [path]. If [readonly] is [true], + the store will only be accessed in read only mode. *) + val init : path:string -> 'a mode -> 'a t Lwt.t + + (** Returns [true] if the key has a value associated in + the store. *) + val mem : [> `Read] t -> key -> bool Lwt.t + + (** Returns the value associated to a key in the store, + or [None] otherwise. *) + val find : [> `Read] t -> key -> value option Lwt.t + + (** Add an association from a key to a value in the + store. If [flush] (default to [true]) is set, the index is written on disk + right away. *) + val add : ?flush:bool -> [> `Write] t -> key -> value -> unit Lwt.t + + (** Closes the store. After this call the store cannot be accessed anymore. *) + val close : _ t -> unit Lwt.t +end + +(** An index store mapping keys to values. Keys are associated to optional + values in the index which allows them to be removed. *) +module type INDEXABLE_REMOVABLE_STORE = sig + include INDEXABLE_STORE + + (** Removes an association from the store. Does nothing if the key was not + registered. *) + val remove : ?flush:bool -> [> `Write] t -> key -> unit Lwt.t +end + +(** An indexed file (i.e. a file and an index) mapping keys to values. The + values can vary in size. *) +module type INDEXED_FILE = sig + (** The type of indexed file store *) + type +'a t + + (** The type of keys *) + type key + + (** The type of headers stored in the index. The header can contain fixed size + information that can be accessed more efficiently than the full value. *) + type header + + (** The type of values stored in the file. *) + type value + + (** Returns [true] if the key has a value associated in + the store. *) + val mem : [> `Read] t -> key -> bool Lwt.t + + (** Returns the header for a key if it exists in the store. *) + val header : [> `Read] t -> key -> header option Lwt.t + + (** Read a full value from the indexed file store. *) + val read : [> `Read] t -> key -> value option Lwt.t + + (** Append a new binding to the indexed file store. *) + val append : + ?flush:bool -> [> `Write] t -> key:key -> value:value -> unit Lwt.t + + (** Initialize a new indexed file store in the directory [data_dir]. *) + val init : data_dir:string -> cache_size:int -> 'a mode -> 'a t Lwt.t + + (** Close the index and the file. *) + val close : _ t -> unit Lwt.t +end + +(** Values that can be encoded. *) +module type ENCODABLE_VALUE = sig + type t + + val name : string + + val encoding : t Data_encoding.t +end + +(** Values that can be encoded and whose encoding is a fixed size. *) +module type FIXED_ENCODABLE_VALUE = sig + include ENCODABLE_VALUE + + val fixed_size : int +end + +(** Values with a given fixed size header. *) +module type ENCODABLE_VALUE_HEADER = sig + include ENCODABLE_VALUE + + module Header : FIXED_ENCODABLE_VALUE +end + +(** {2 Functors} *) + +module Make_singleton (S : ENCODABLE_VALUE) : + SINGLETON_STORE with type value := S.t + +module Make_indexable (K : Index.Key.S) (V : Index.Value.S) : + INDEXABLE_STORE with type key := K.t and type value := V.t + +module Make_indexable_removable (K : Index.Key.S) (V : Index.Value.S) : + INDEXABLE_REMOVABLE_STORE with type key := K.t and type value := V.t + +module Make_indexed_file (K : Index.Key.S) (V : ENCODABLE_VALUE_HEADER) : + INDEXED_FILE + with type key := K.t + and type value := V.t + and type header := V.Header.t + +(** {2 Helper functors} *) + +module Make_fixed_encodable (V : ENCODABLE_VALUE) : + FIXED_ENCODABLE_VALUE with type t = V.t + +module Make_index_value (E : FIXED_ENCODABLE_VALUE) : + Index.Value.S with type t = E.t + +module Make_index_key (E : sig + include FIXED_ENCODABLE_VALUE + + val equal : t -> t -> bool +end) : Index.Key.S with type t = E.t -- GitLab From 59a047a12ee554e2aba0aa953d3c465f18a9ce81 Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Thu, 8 Dec 2022 10:22:04 +0100 Subject: [PATCH 02/11] Layer2/Store: add a cache for singleton store --- src/lib_layer2_store/indexed_store.ml | 23 ++++++++++++++++++----- 1 file changed, 18 insertions(+), 5 deletions(-) diff --git a/src/lib_layer2_store/indexed_store.ml b/src/lib_layer2_store/indexed_store.ml index c453413d72b9..96e9b83f50f1 100644 --- a/src/lib_layer2_store/indexed_store.ml +++ b/src/lib_layer2_store/indexed_store.ml @@ -316,9 +316,9 @@ module Make_singleton (S : sig val encoding : t Data_encoding.t end) : SINGLETON_STORE with type value := S.t = struct - type 'a t = {file : string} + type 'a t = {file : string; mutable cache : S.t option option} - let read store = + let read_disk store = let open Lwt_syntax in let* exists = Lwt_unix.file_exists store.file in match exists with @@ -334,7 +334,10 @@ end) : SINGLETON_STORE with type value := S.t = struct S.encoding (Bytes.unsafe_of_string bytes) - let write store x = + let read store = + match store.cache with Some v -> Lwt.return v | None -> read_disk store + + let write_disk store x = let open Lwt_result_syntax in let*! res = Lwt_utils_unix.with_atomic_open_out ~overwrite:true store.file @@ -351,14 +354,24 @@ end) : SINGLETON_STORE with type value := S.t = struct | Ok res -> Lwt.return res | Error _ -> tzfail (Cannot_write_file S.name) - let delete store = + let write store x = + let open Lwt_result_syntax in + let+ () = write_disk store x in + store.cache <- Some (Some x) + + let delete_disk store = let open Lwt_syntax in let* exists = Lwt_unix.file_exists store.file in match exists with | false -> return_unit | true -> Lwt_unix.unlink store.file - let init ~path _mode = Lwt.return {file = path} + let delete store = + let open Lwt_syntax in + let+ () = delete_disk store in + store.cache <- Some None + + let init ~path _mode = Lwt.return {file = path; cache = None} end module Make_indexed_file (K : Index.Key.S) (V : ENCODABLE_VALUE_HEADER) = struct -- GitLab From 0102ea8e68575f45f60a1bfcfaa38c67f7144f08 Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Thu, 8 Dec 2022 11:38:29 +0100 Subject: [PATCH 03/11] Layer2/Store: Better error handling --- src/lib_layer2_store/indexed_store.ml | 306 ++++++++++++++++--------- src/lib_layer2_store/indexed_store.mli | 46 ++-- 2 files changed, 223 insertions(+), 129 deletions(-) diff --git a/src/lib_layer2_store/indexed_store.ml b/src/lib_layer2_store/indexed_store.ml index 96e9b83f50f1..f3a5082f979a 100644 --- a/src/lib_layer2_store/indexed_store.ml +++ b/src/lib_layer2_store/indexed_store.ml @@ -25,33 +25,65 @@ open Store_sigs -type error += Cannot_encode_data of string +type error += + | Cannot_load_store of string * string + | Cannot_write_to_store of string + | Cannot_read_from_store of string + | Decoding_error of Data_encoding.Binary.read_error let () = register_error_kind - ~id:"layer2_store.cannot_encode_data" - ~title:"Data cannot be encoded" - ~description:"Data cannot be encoded to be stored on disk." + ~id:"layer2_store.cannot_load_store" + ~title:"Store cannot be loaded" + ~description:"Store cannot be loaded." + ~pp:(fun ppf (name, path) -> + Format.fprintf ppf "Store %s cannot be loaded from %s." name path) + `Permanent + Data_encoding.(obj2 (req "name" string) (req "path" string)) + (function Cannot_load_store (n, p) -> Some (n, p) | _ -> None) + (fun (n, p) -> Cannot_load_store (n, p)) + +let () = + register_error_kind + ~id:"layer2_store.cannot_write_to_store" + ~title:"Value cannot be written to store" + ~description:"Value cannot be written to store." ~pp:(fun ppf name -> - Format.fprintf ppf "Data %s cannot be encoded to be stored on disk." name) + Format.fprintf ppf "Value cannot be written to store %s." name) `Permanent Data_encoding.(obj1 (req "name" string)) - (function Cannot_encode_data n -> Some n | _ -> None) - (fun n -> Cannot_encode_data n) - -type error += Cannot_write_file of string + (function Cannot_write_to_store n -> Some n | _ -> None) + (fun n -> Cannot_write_to_store n) let () = register_error_kind - ~id:"layer2_store.cannot_write_file" - ~title:"File cannot be written" - ~description:"File cannot be written to disk." + ~id:"layer2_store.cannot_read_from_store" + ~title:"Value cannot be read from store" + ~description:"Value cannot be read from store." ~pp:(fun ppf name -> - Format.fprintf ppf "File %s cannot be written to disk." name) + Format.fprintf ppf "Value cannot be read from store %s." name) `Permanent Data_encoding.(obj1 (req "name" string)) - (function Cannot_write_file n -> Some n | _ -> None) - (fun n -> Cannot_write_file n) + (function Cannot_read_from_store n -> Some n | _ -> None) + (fun n -> Cannot_read_from_store n) + +let () = + register_error_kind + ~id:"layer2_store.decoding_error" + ~title:"Cannot decode file" + ~description:"A file for a persistent element could not be decoded" + ~pp:(fun ppf error -> + Format.fprintf + ppf + "Decoding error: %a" + Data_encoding.Json.pp + (Data_encoding.Json.construct + Data_encoding.Binary.read_error_encoding + error)) + `Permanent + Data_encoding.(obj1 (req "error" Data_encoding.Binary.read_error_encoding)) + (function Decoding_error e -> Some e | _ -> None) + (fun e -> Decoding_error e) (* Helper functions to copy byte sequences or integers in [src] to another byte sequence [dst] at offset [offset], with named arguments to avoid @@ -85,18 +117,22 @@ let read_int8 str offset = (* Functors to build stores on indexes *) +module type NAME = sig + val name : string +end + module type SINGLETON_STORE = sig type +'a t type value - val init : path:string -> 'a mode -> 'a t Lwt.t + val init : path:string -> 'a mode -> 'a t tzresult Lwt.t - val read : [> `Read] t -> value option Lwt.t + val read : [> `Read] t -> value option tzresult Lwt.t val write : [> `Write] t -> value -> unit tzresult Lwt.t - val delete : [> `Write] t -> unit Lwt.t + val delete : [> `Write] t -> unit tzresult Lwt.t end module type INDEXABLE_STORE = sig @@ -106,21 +142,21 @@ module type INDEXABLE_STORE = sig type value - val init : path:string -> 'a mode -> 'a t Lwt.t + val init : path:string -> 'a mode -> 'a t tzresult Lwt.t - val mem : [> `Read] t -> key -> bool Lwt.t + val mem : [> `Read] t -> key -> bool tzresult Lwt.t - val find : [> `Read] t -> key -> value option Lwt.t + val find : [> `Read] t -> key -> value option tzresult Lwt.t - val add : ?flush:bool -> [> `Write] t -> key -> value -> unit Lwt.t + val add : ?flush:bool -> [> `Write] t -> key -> value -> unit tzresult Lwt.t - val close : _ t -> unit Lwt.t + val close : _ t -> unit tzresult Lwt.t end module type INDEXABLE_REMOVABLE_STORE = sig include INDEXABLE_STORE - val remove : ?flush:bool -> [> `Write] t -> key -> unit Lwt.t + val remove : ?flush:bool -> [> `Write] t -> key -> unit tzresult Lwt.t end module type INDEXED_FILE = sig @@ -132,18 +168,18 @@ module type INDEXED_FILE = sig type value - val mem : [> `Read] t -> key -> bool Lwt.t + val mem : [> `Read] t -> key -> bool tzresult Lwt.t - val header : [> `Read] t -> key -> header option Lwt.t + val header : [> `Read] t -> key -> header option tzresult Lwt.t - val read : [> `Read] t -> key -> value option Lwt.t + val read : [> `Read] t -> key -> value option tzresult Lwt.t val append : - ?flush:bool -> [> `Write] t -> key:key -> value:value -> unit Lwt.t + ?flush:bool -> [> `Write] t -> key:key -> value:value -> unit tzresult Lwt.t - val init : data_dir:string -> cache_size:int -> 'a mode -> 'a t Lwt.t + val init : data_dir:string -> cache_size:int -> 'a mode -> 'a t tzresult Lwt.t - val close : _ t -> unit Lwt.t + val close : _ t -> unit tzresult Lwt.t end module type ENCODABLE_VALUE = sig @@ -213,7 +249,7 @@ end) : Index.Key.S with type t = E.t = struct let hash_size = 30 (* in bits *) end -module Make_indexable (K : Index.Key.S) (V : Index.Value.S) = struct +module Make_indexable (N : NAME) (K : Index.Key.S) (V : Index.Value.S) = struct module I = Index_unix.Make (K) (V) (Index.Cache.Unbounded) type _ t = {index : I.t; scheduler : Lwt_idle_waiter.t} @@ -223,35 +259,52 @@ module Make_indexable (K : Index.Key.S) (V : Index.Value.S) = struct let log_size = 10_000 let mem store k = + let open Lwt_result_syntax in + trace (Cannot_read_from_store N.name) + @@ protect + @@ fun () -> Lwt_idle_waiter.task store.scheduler @@ fun () -> - Lwt.return (I.mem store.index k) + return (I.mem store.index k) let find store k = - let open Lwt_syntax in + let open Lwt_result_syntax in + trace (Cannot_read_from_store N.name) + @@ protect + @@ fun () -> Lwt_idle_waiter.task store.scheduler @@ fun () -> - Option.catch_os @@ fun () -> - let v = I.find store.index k in - return_some v + let v = try Some (I.find store.index k) with Not_found -> None in + return v let add ?(flush = true) store k v = + let open Lwt_result_syntax in + trace (Cannot_write_to_store N.name) + @@ protect + @@ fun () -> Lwt_idle_waiter.force_idle store.scheduler @@ fun () -> I.replace store.index k v ; if flush then I.flush store.index ; - Lwt.return_unit + return_unit - let init (type a) ~path (mode : a mode) : a t Lwt.t = + let init (type a) ~path (mode : a mode) : a t tzresult Lwt.t = + let open Lwt_result_syntax in + trace (Cannot_load_store (N.name, path)) + @@ protect + @@ fun () -> let readonly = match mode with Read_only -> true | Read_write -> false in let index = I.v ~log_size ~readonly path in let scheduler = Lwt_idle_waiter.create () in - Lwt.return {index; scheduler} + return {index; scheduler} let close store = + let open Lwt_result_syntax in + protect @@ fun () -> Lwt_idle_waiter.force_idle store.scheduler @@ fun () -> (try I.close store.index with Index.Closed -> ()) ; - Lwt.return_unit + return_unit end -module Make_indexable_removable (K : Index.Key.S) (V : Index.Value.S) = struct +module Make_indexable_removable (N : NAME) (K : Index.Key.S) (V : Index.Value.S) = +struct module V_opt = struct (* The values stored in the index are optional values. When we "remove" a key from the store, we're not really removing it from the index, but @@ -285,28 +338,32 @@ module Make_indexable_removable (K : Index.Key.S) (V : Index.Value.S) = struct | _ -> assert false end - include Make_indexable (K) (V_opt) + include Make_indexable (N) (K) (V_opt) let find store k = - let open Lwt_syntax in + let open Lwt_result_syntax in let+ v = find store k in match v with None | Some None -> None | Some (Some v) -> Some v let mem store hash = - let open Lwt_syntax in + let open Lwt_result_syntax in let+ b = find store hash in Option.is_some b let add ?flush store k v = add ?flush store k (Some v) let remove ?(flush = true) store k = + let open Lwt_result_syntax in + trace (Cannot_write_to_store N.name) + @@ protect + @@ fun () -> Lwt_idle_waiter.force_idle store.scheduler @@ fun () -> let exists = I.mem store.index k in - if not exists then Lwt.return_unit + if not exists then return_unit else ( I.replace store.index k None ; if flush then I.flush store.index ; - Lwt.return_unit) + return_unit) end module Make_singleton (S : sig @@ -319,40 +376,39 @@ end) : SINGLETON_STORE with type value := S.t = struct type 'a t = {file : string; mutable cache : S.t option option} let read_disk store = - let open Lwt_syntax in - let* exists = Lwt_unix.file_exists store.file in + let open Lwt_result_syntax in + trace (Cannot_read_from_store S.name) + @@ protect + @@ fun () -> + let*! exists = Lwt_unix.file_exists store.file in match exists with | false -> return_none - | true -> + | true -> ( Lwt_io.with_file ~flags:[Unix.O_RDONLY; O_CLOEXEC] ~mode:Input store.file @@ fun channel -> - let+ bytes = Lwt_io.read channel in - Data_encoding.Binary.of_bytes_opt - S.encoding - (Bytes.unsafe_of_string bytes) + let*! raw_data = Lwt_io.read channel in + let data = Data_encoding.Binary.of_string S.encoding raw_data in + match data with + | Ok data -> return_some data + | Error err -> tzfail (Decoding_error err)) let read store = - match store.cache with Some v -> Lwt.return v | None -> read_disk store + let open Lwt_result_syntax in + match store.cache with Some v -> return v | None -> read_disk store let write_disk store x = let open Lwt_result_syntax in - let*! res = - Lwt_utils_unix.with_atomic_open_out ~overwrite:true store.file - @@ fun fd -> - let* block_bytes = - match Data_encoding.Binary.to_bytes_opt S.encoding x with - | None -> tzfail (Cannot_encode_data S.name) - | Some bytes -> return bytes - in - let*! () = Lwt_utils_unix.write_bytes fd block_bytes in - return_unit - in - match res with - | Ok res -> Lwt.return res - | Error _ -> tzfail (Cannot_write_file S.name) + trace (Cannot_write_to_store S.name) + @@ let*! res = + Lwt_utils_unix.with_atomic_open_out ~overwrite:true store.file + @@ fun fd -> + let block_bytes = Data_encoding.Binary.to_bytes_exn S.encoding x in + Lwt_utils_unix.write_bytes fd block_bytes + in + Result.bind_error res Lwt_utils_unix.tzfail_of_io_error |> Lwt.return let write store x = let open Lwt_result_syntax in @@ -360,26 +416,37 @@ end) : SINGLETON_STORE with type value := S.t = struct store.cache <- Some (Some x) let delete_disk store = - let open Lwt_syntax in - let* exists = Lwt_unix.file_exists store.file in + let open Lwt_result_syntax in + trace (Cannot_write_to_store S.name) + @@ protect + @@ fun () -> + let*! exists = Lwt_unix.file_exists store.file in match exists with | false -> return_unit - | true -> Lwt_unix.unlink store.file + | true -> + let*! () = Lwt_unix.unlink store.file in + return_unit let delete store = - let open Lwt_syntax in + let open Lwt_result_syntax in let+ () = delete_disk store in store.cache <- Some None - let init ~path _mode = Lwt.return {file = path; cache = None} + let init ~path _mode = Lwt_result.return {file = path; cache = None} end -module Make_indexed_file (K : Index.Key.S) (V : ENCODABLE_VALUE_HEADER) = struct +module Make_indexed_file + (N : NAME) + (K : Index.Key.S) + (V : ENCODABLE_VALUE_HEADER) = +struct module Cache = Aches_lwt.Lache.Make_option (Aches.Rache.Transfer (Aches.Rache.LRU) (K)) module Raw_header = Make_index_value (V.Header) module IHeader = struct + let name = N.name ^ ".header" + type t = {offset : int; header : V.Header.t} let encoded_size = 8 (* offset *) + Raw_header.encoded_size @@ -410,17 +477,20 @@ module Make_indexed_file (K : Index.Key.S) (V : ENCODABLE_VALUE_HEADER) = struct module Values_file = struct let encoding = Data_encoding.dynamic_size ~kind:`Uint30 V.encoding - let pread_value_exn fd ~file_offset = - let open Lwt_syntax in + let pread_value fd ~file_offset = + let open Lwt_result_syntax in + trace (Cannot_read_from_store N.name) + @@ protect + @@ fun () -> (* Read length *) let length_bytes = Bytes.create 4 in - let* () = + let*! () = Lwt_utils_unix.read_bytes ~file_offset ~pos:0 ~len:4 fd length_bytes in let value_length_int32 = Bytes.get_int32_be length_bytes 0 in let value_length = Int32.to_int value_length_int32 in let value_bytes = Bytes.extend length_bytes 0 value_length in - let* () = + let*! () = Lwt_utils_unix.read_bytes ~file_offset:(file_offset + 4) ~pos:4 @@ -428,19 +498,16 @@ module Make_indexed_file (K : Index.Key.S) (V : ENCODABLE_VALUE_HEADER) = struct fd value_bytes in - Lwt.return - ( Data_encoding.Binary.of_bytes_exn encoding value_bytes, - 4 + value_length ) - - let pread_value fd ~file_offset = - Option.catch_s (fun () -> pread_value_exn fd ~file_offset) + match Data_encoding.Binary.of_bytes encoding value_bytes with + | Ok value -> return (value, 4 + value_length) + | Error err -> tzfail (Decoding_error err) end type +'a t = { index : Header_index.t; fd : Lwt_unix.file_descr; scheduler : Lwt_idle_waiter.t; - cache : V.t Cache.t; + cache : V.t tzresult Cache.t; } (* The log_size corresponds to the maximum size of the memory zone @@ -452,57 +519,77 @@ module Make_indexed_file (K : Index.Key.S) (V : ENCODABLE_VALUE_HEADER) = struct let blocks_log_size = 10_000 let mem store key = + let open Lwt_result_syntax in + trace (Cannot_read_from_store IHeader.name) + @@ protect + @@ fun () -> Lwt_idle_waiter.task store.scheduler @@ fun () -> - Lwt.return (Header_index.mem store.index key) + return (Header_index.mem store.index key) let header store key = + let open Lwt_result_syntax in + trace (Cannot_read_from_store IHeader.name) + @@ protect + @@ fun () -> Lwt_idle_waiter.task store.scheduler @@ fun () -> try let {IHeader.header; _} = Header_index.find store.index key in - Lwt.return_some header - with Not_found -> Lwt.return_none + return_some header + with Not_found -> return_none let read store key = - let open Lwt_syntax in Lwt_idle_waiter.task store.scheduler @@ fun () -> - Option.catch_os @@ fun () -> let read_from_disk key = - let {IHeader.offset; _} = Header_index.find store.index key in - let* o = Values_file.pread_value store.fd ~file_offset:offset in - match o with - | Some (value, _) -> Lwt.return_some value - | None -> Lwt.return_none + let open Lwt_syntax in + match Header_index.find store.index key with + | exception Not_found -> Lwt.return_none + | {IHeader.offset; _} -> + let+ value = Values_file.pread_value store.fd ~file_offset:offset in + Some (Result.map fst value) in - Cache.bind_or_put store.cache key read_from_disk Lwt.return + let open Lwt_result_syntax in + Cache.bind_or_put store.cache key read_from_disk @@ function + | None -> return_none + | Some (Ok value) -> return_some value + | Some (Error _ as e) -> Lwt.return e let locked_write_value store ~offset ~value ~key = - let open Lwt_syntax in + trace (Cannot_write_to_store N.name) + @@ protect + @@ fun () -> + let open Lwt_result_syntax in let value_bytes = Data_encoding.Binary.to_bytes_exn Values_file.encoding value in let value_length = Bytes.length value_bytes in - let* () = + let*! () = Lwt_utils_unix.write_bytes ~pos:0 ~len:value_length store.fd value_bytes in Header_index.replace store.index key {offset; header = V.header value} ; return value_length let append ?(flush = true) store ~key ~(value : V.t) = - let open Lwt_syntax in + trace (Cannot_write_to_store N.name) + @@ protect + @@ fun () -> + let open Lwt_result_syntax in Lwt_idle_waiter.force_idle store.scheduler @@ fun () -> - Cache.put store.cache key (return_some value) ; - let* offset = Lwt_unix.lseek store.fd 0 Unix.SEEK_END in - let* _written_len = locked_write_value store ~offset ~value ~key in + Cache.put store.cache key (Lwt.return_some (Ok value)) ; + let*! offset = Lwt_unix.lseek store.fd 0 Unix.SEEK_END in + let*! _written_len = locked_write_value store ~offset ~value ~key in if flush then Header_index.flush store.index ; - Lwt.return_unit + return_unit - let init (type a) ~data_dir ~cache_size (mode : a mode) : a t Lwt.t = - let open Lwt_syntax in + let init (type a) ~data_dir ~cache_size (mode : a mode) : a t tzresult Lwt.t = + let open Lwt_result_syntax in + trace (Cannot_load_store (N.name, path)) + @@ protect + @@ fun () -> let readonly = match mode with Read_only -> true | Read_write -> false in let flag, perms = if readonly then (Unix.O_RDONLY, 0o444) else (Unix.O_RDWR, 0o644) in - let* fd = + let*! fd = Lwt_unix.openfile (Filename.concat data_dir "data") [Unix.O_CREAT; O_CLOEXEC; flag] @@ -516,12 +603,11 @@ module Make_indexed_file (K : Index.Key.S) (V : ENCODABLE_VALUE_HEADER) = struct in let scheduler = Lwt_idle_waiter.create () in let cache = Cache.create cache_size in - Lwt.return {index; fd; scheduler; cache} + return {index; fd; scheduler; cache} let close store = - let open Lwt_syntax in + protect @@ fun () -> Lwt_idle_waiter.force_idle store.scheduler @@ fun () -> (try Header_index.close store.index with Index.Closed -> ()) ; - let* _ignore = Lwt_utils_unix.safe_close store.fd in - Lwt.return_unit + Lwt_utils_unix.safe_close store.fd end diff --git a/src/lib_layer2_store/indexed_store.mli b/src/lib_layer2_store/indexed_store.mli index 650801c3240f..bd7862267258 100644 --- a/src/lib_layer2_store/indexed_store.mli +++ b/src/lib_layer2_store/indexed_store.mli @@ -38,17 +38,17 @@ module type SINGLETON_STORE = sig type value (** Initializes a singleton store in the file [path]. *) - val init : path:string -> 'a mode -> 'a t Lwt.t + val init : path:string -> 'a mode -> 'a t tzresult Lwt.t (** Reads the current value from the disk. Returns [None] if the - file does not exist or if it is corrupted. *) - val read : [> `Read] t -> value option Lwt.t + file does not exist. *) + val read : [> `Read] t -> value option tzresult Lwt.t (** Write the value to disk. *) val write : [> `Write] t -> value -> unit tzresult Lwt.t (** Deletes the value from the disk. *) - val delete : [> `Write] t -> unit Lwt.t + val delete : [> `Write] t -> unit tzresult Lwt.t end (** An index store mapping keys to values. It is composed of an index only. *) @@ -64,23 +64,23 @@ module type INDEXABLE_STORE = sig (** Initializes a store in the file [path]. If [readonly] is [true], the store will only be accessed in read only mode. *) - val init : path:string -> 'a mode -> 'a t Lwt.t + val init : path:string -> 'a mode -> 'a t tzresult Lwt.t (** Returns [true] if the key has a value associated in the store. *) - val mem : [> `Read] t -> key -> bool Lwt.t + val mem : [> `Read] t -> key -> bool tzresult Lwt.t (** Returns the value associated to a key in the store, or [None] otherwise. *) - val find : [> `Read] t -> key -> value option Lwt.t + val find : [> `Read] t -> key -> value option tzresult Lwt.t (** Add an association from a key to a value in the store. If [flush] (default to [true]) is set, the index is written on disk right away. *) - val add : ?flush:bool -> [> `Write] t -> key -> value -> unit Lwt.t + val add : ?flush:bool -> [> `Write] t -> key -> value -> unit tzresult Lwt.t (** Closes the store. After this call the store cannot be accessed anymore. *) - val close : _ t -> unit Lwt.t + val close : _ t -> unit tzresult Lwt.t end (** An index store mapping keys to values. Keys are associated to optional @@ -90,7 +90,7 @@ module type INDEXABLE_REMOVABLE_STORE = sig (** Removes an association from the store. Does nothing if the key was not registered. *) - val remove : ?flush:bool -> [> `Write] t -> key -> unit Lwt.t + val remove : ?flush:bool -> [> `Write] t -> key -> unit tzresult Lwt.t end (** An indexed file (i.e. a file and an index) mapping keys to values. The @@ -111,23 +111,28 @@ module type INDEXED_FILE = sig (** Returns [true] if the key has a value associated in the store. *) - val mem : [> `Read] t -> key -> bool Lwt.t + val mem : [> `Read] t -> key -> bool tzresult Lwt.t (** Returns the header for a key if it exists in the store. *) - val header : [> `Read] t -> key -> header option Lwt.t + val header : [> `Read] t -> key -> header option tzresult Lwt.t (** Read a full value from the indexed file store. *) - val read : [> `Read] t -> key -> value option Lwt.t + val read : [> `Read] t -> key -> value option tzresult Lwt.t (** Append a new binding to the indexed file store. *) val append : - ?flush:bool -> [> `Write] t -> key:key -> value:value -> unit Lwt.t + ?flush:bool -> [> `Write] t -> key:key -> value:value -> unit tzresult Lwt.t (** Initialize a new indexed file store in the directory [data_dir]. *) - val init : data_dir:string -> cache_size:int -> 'a mode -> 'a t Lwt.t + val init : data_dir:string -> cache_size:int -> 'a mode -> 'a t tzresult Lwt.t (** Close the index and the file. *) - val close : _ t -> unit Lwt.t + val close : _ t -> unit tzresult Lwt.t +end + +(** Names for stores. *) +module type NAME = sig + val name : string end (** Values that can be encoded. *) @@ -158,13 +163,16 @@ end module Make_singleton (S : ENCODABLE_VALUE) : SINGLETON_STORE with type value := S.t -module Make_indexable (K : Index.Key.S) (V : Index.Value.S) : +module Make_indexable (_ : NAME) (K : Index.Key.S) (V : Index.Value.S) : INDEXABLE_STORE with type key := K.t and type value := V.t -module Make_indexable_removable (K : Index.Key.S) (V : Index.Value.S) : +module Make_indexable_removable (_ : NAME) (K : Index.Key.S) (V : Index.Value.S) : INDEXABLE_REMOVABLE_STORE with type key := K.t and type value := V.t -module Make_indexed_file (K : Index.Key.S) (V : ENCODABLE_VALUE_HEADER) : +module Make_indexed_file + (_ : NAME) + (K : Index.Key.S) + (V : ENCODABLE_VALUE_HEADER) : INDEXED_FILE with type key := K.t and type value := V.t -- GitLab From 6028c26c9a37a80a17cd63e8b2b86002ce5b739b Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Thu, 8 Dec 2022 11:56:54 +0100 Subject: [PATCH 04/11] Layer2/Store: rename init to load and use ~path everywhere --- src/lib_layer2_store/indexed_store.ml | 16 ++++++++-------- src/lib_layer2_store/indexed_store.mli | 12 ++++++------ 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/src/lib_layer2_store/indexed_store.ml b/src/lib_layer2_store/indexed_store.ml index f3a5082f979a..260ea1939eff 100644 --- a/src/lib_layer2_store/indexed_store.ml +++ b/src/lib_layer2_store/indexed_store.ml @@ -126,7 +126,7 @@ module type SINGLETON_STORE = sig type value - val init : path:string -> 'a mode -> 'a t tzresult Lwt.t + val load : path:string -> 'a mode -> 'a t tzresult Lwt.t val read : [> `Read] t -> value option tzresult Lwt.t @@ -142,7 +142,7 @@ module type INDEXABLE_STORE = sig type value - val init : path:string -> 'a mode -> 'a t tzresult Lwt.t + val load : path:string -> 'a mode -> 'a t tzresult Lwt.t val mem : [> `Read] t -> key -> bool tzresult Lwt.t @@ -177,7 +177,7 @@ module type INDEXED_FILE = sig val append : ?flush:bool -> [> `Write] t -> key:key -> value:value -> unit tzresult Lwt.t - val init : data_dir:string -> cache_size:int -> 'a mode -> 'a t tzresult Lwt.t + val load : path:string -> cache_size:int -> 'a mode -> 'a t tzresult Lwt.t val close : _ t -> unit tzresult Lwt.t end @@ -285,7 +285,7 @@ module Make_indexable (N : NAME) (K : Index.Key.S) (V : Index.Value.S) = struct if flush then I.flush store.index ; return_unit - let init (type a) ~path (mode : a mode) : a t tzresult Lwt.t = + let load (type a) ~path (mode : a mode) : a t tzresult Lwt.t = let open Lwt_result_syntax in trace (Cannot_load_store (N.name, path)) @@ protect @@ -432,7 +432,7 @@ end) : SINGLETON_STORE with type value := S.t = struct let+ () = delete_disk store in store.cache <- Some None - let init ~path _mode = Lwt_result.return {file = path; cache = None} + let load ~path _mode = Lwt_result.return {file = path; cache = None} end module Make_indexed_file @@ -580,7 +580,7 @@ struct if flush then Header_index.flush store.index ; return_unit - let init (type a) ~data_dir ~cache_size (mode : a mode) : a t tzresult Lwt.t = + let load (type a) ~path ~cache_size (mode : a mode) : a t tzresult Lwt.t = let open Lwt_result_syntax in trace (Cannot_load_store (N.name, path)) @@ protect @@ -591,7 +591,7 @@ struct in let*! fd = Lwt_unix.openfile - (Filename.concat data_dir "data") + (Filename.concat path "data") [Unix.O_CREAT; O_CLOEXEC; flag] perms in @@ -599,7 +599,7 @@ struct Header_index.v ~log_size:blocks_log_size ~readonly - (Filename.concat data_dir "index") + (Filename.concat path "index") in let scheduler = Lwt_idle_waiter.create () in let cache = Cache.create cache_size in diff --git a/src/lib_layer2_store/indexed_store.mli b/src/lib_layer2_store/indexed_store.mli index bd7862267258..c1d5fb9503b0 100644 --- a/src/lib_layer2_store/indexed_store.mli +++ b/src/lib_layer2_store/indexed_store.mli @@ -37,8 +37,8 @@ module type SINGLETON_STORE = sig (** The type of values stored in this singleton store. *) type value - (** Initializes a singleton store in the file [path]. *) - val init : path:string -> 'a mode -> 'a t tzresult Lwt.t + (** Load (or initializes) a singleton store in the file [path]. *) + val load : path:string -> 'a mode -> 'a t tzresult Lwt.t (** Reads the current value from the disk. Returns [None] if the file does not exist. *) @@ -62,9 +62,9 @@ module type INDEXABLE_STORE = sig (** The type of values stored in the index *) type value - (** Initializes a store in the file [path]. If [readonly] is [true], + (** Load (or initializes) a store in the file [path]. If [readonly] is [true], the store will only be accessed in read only mode. *) - val init : path:string -> 'a mode -> 'a t tzresult Lwt.t + val load : path:string -> 'a mode -> 'a t tzresult Lwt.t (** Returns [true] if the key has a value associated in the store. *) @@ -123,8 +123,8 @@ module type INDEXED_FILE = sig val append : ?flush:bool -> [> `Write] t -> key:key -> value:value -> unit tzresult Lwt.t - (** Initialize a new indexed file store in the directory [data_dir]. *) - val init : data_dir:string -> cache_size:int -> 'a mode -> 'a t tzresult Lwt.t + (** Loads a new or existing indexed file store in the directory [path]. *) + val load : path:string -> cache_size:int -> 'a mode -> 'a t tzresult Lwt.t (** Close the index and the file. *) val close : _ t -> unit tzresult Lwt.t -- GitLab From 478276f3857438d574ac2be92ce4e8276655c8fc Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Thu, 8 Dec 2022 11:59:11 +0100 Subject: [PATCH 05/11] Layer2/Store: create directory for store if it does not exist --- src/lib_layer2_store/indexed_store.ml | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/lib_layer2_store/indexed_store.ml b/src/lib_layer2_store/indexed_store.ml index 260ea1939eff..495a5556b890 100644 --- a/src/lib_layer2_store/indexed_store.ml +++ b/src/lib_layer2_store/indexed_store.ml @@ -290,6 +290,7 @@ module Make_indexable (N : NAME) (K : Index.Key.S) (V : Index.Value.S) = struct trace (Cannot_load_store (N.name, path)) @@ protect @@ fun () -> + let*! () = Lwt_utils_unix.create_dir (Filename.dirname path) in let readonly = match mode with Read_only -> true | Read_write -> false in let index = I.v ~log_size ~readonly path in let scheduler = Lwt_idle_waiter.create () in @@ -432,7 +433,13 @@ end) : SINGLETON_STORE with type value := S.t = struct let+ () = delete_disk store in store.cache <- Some None - let load ~path _mode = Lwt_result.return {file = path; cache = None} + let load ~path _mode = + let open Lwt_result_syntax in + trace (Cannot_load_store (S.name, path)) + @@ protect + @@ fun () -> + let*! () = Lwt_utils_unix.create_dir (Filename.dirname path) in + return {file = path; cache = None} end module Make_indexed_file @@ -585,6 +592,7 @@ struct trace (Cannot_load_store (N.name, path)) @@ protect @@ fun () -> + let*! () = Lwt_utils_unix.create_dir path in let readonly = match mode with Read_only -> true | Read_write -> false in let flag, perms = if readonly then (Unix.O_RDONLY, 0o444) else (Unix.O_RDWR, 0o644) -- GitLab From 223e2610cd8a9cdc0df5427d6036b0718beba8ed Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Thu, 8 Dec 2022 12:18:05 +0100 Subject: [PATCH 06/11] Layer2/Store: allow to provide header manually --- src/lib_layer2_store/indexed_store.ml | 38 +++++++++++++++++++++----- src/lib_layer2_store/indexed_store.mli | 28 ++++++++++++++++++- 2 files changed, 58 insertions(+), 8 deletions(-) diff --git a/src/lib_layer2_store/indexed_store.ml b/src/lib_layer2_store/indexed_store.ml index 495a5556b890..d9b135d488ae 100644 --- a/src/lib_layer2_store/indexed_store.ml +++ b/src/lib_layer2_store/indexed_store.ml @@ -175,13 +175,25 @@ module type INDEXED_FILE = sig val read : [> `Read] t -> key -> value option tzresult Lwt.t val append : - ?flush:bool -> [> `Write] t -> key:key -> value:value -> unit tzresult Lwt.t + ?flush:bool -> + [> `Write] t -> + key:key -> + header:header -> + value:value -> + unit tzresult Lwt.t val load : path:string -> cache_size:int -> 'a mode -> 'a t tzresult Lwt.t val close : _ t -> unit tzresult Lwt.t end +module type SIMPLE_INDEXED_FILE = sig + include INDEXED_FILE + + val append : + ?flush:bool -> [> `Write] t -> key:key -> value:value -> unit tzresult Lwt.t +end + module type ENCODABLE_VALUE = sig type t @@ -200,8 +212,6 @@ module type ENCODABLE_VALUE_HEADER = sig include ENCODABLE_VALUE module Header : FIXED_ENCODABLE_VALUE - - val header : t -> Header.t end module Make_fixed_encodable (V : ENCODABLE_VALUE) : @@ -560,7 +570,7 @@ struct | Some (Ok value) -> return_some value | Some (Error _ as e) -> Lwt.return e - let locked_write_value store ~offset ~value ~key = + let locked_write_value store ~offset ~value ~key ~header = trace (Cannot_write_to_store N.name) @@ protect @@ fun () -> @@ -572,10 +582,10 @@ struct let*! () = Lwt_utils_unix.write_bytes ~pos:0 ~len:value_length store.fd value_bytes in - Header_index.replace store.index key {offset; header = V.header value} ; + Header_index.replace store.index key {offset; header} ; return value_length - let append ?(flush = true) store ~key ~(value : V.t) = + let append ?(flush = true) store ~key ~header ~(value : V.t) = trace (Cannot_write_to_store N.name) @@ protect @@ fun () -> @@ -583,7 +593,7 @@ struct Lwt_idle_waiter.force_idle store.scheduler @@ fun () -> Cache.put store.cache key (Lwt.return_some (Ok value)) ; let*! offset = Lwt_unix.lseek store.fd 0 Unix.SEEK_END in - let*! _written_len = locked_write_value store ~offset ~value ~key in + let*! _written_len = locked_write_value store ~offset ~value ~key ~header in if flush then Header_index.flush store.index ; return_unit @@ -619,3 +629,17 @@ struct (try Header_index.close store.index with Index.Closed -> ()) ; Lwt_utils_unix.safe_close store.fd end + +module Make_simple_indexed_file + (N : NAME) + (K : Index.Key.S) (V : sig + include ENCODABLE_VALUE_HEADER + + val header : t -> Header.t + end) = +struct + include Make_indexed_file (N) (K) (V) + + let append ?flush store ~key ~value = + append ?flush store ~key ~value ~header:(V.header value) +end diff --git a/src/lib_layer2_store/indexed_store.mli b/src/lib_layer2_store/indexed_store.mli index c1d5fb9503b0..fc03c43ffb7d 100644 --- a/src/lib_layer2_store/indexed_store.mli +++ b/src/lib_layer2_store/indexed_store.mli @@ -121,7 +121,12 @@ module type INDEXED_FILE = sig (** Append a new binding to the indexed file store. *) val append : - ?flush:bool -> [> `Write] t -> key:key -> value:value -> unit tzresult Lwt.t + ?flush:bool -> + [> `Write] t -> + key:key -> + header:header -> + value:value -> + unit tzresult Lwt.t (** Loads a new or existing indexed file store in the directory [path]. *) val load : path:string -> cache_size:int -> 'a mode -> 'a t tzresult Lwt.t @@ -130,6 +135,15 @@ module type INDEXED_FILE = sig val close : _ t -> unit tzresult Lwt.t end +(** Same as {!INDEXED_FILE} but where headers are extracted from values. *) +module type SIMPLE_INDEXED_FILE = sig + include INDEXED_FILE + + (** Append a new binding to the indexed file store. *) + val append : + ?flush:bool -> [> `Write] t -> key:key -> value:value -> unit tzresult Lwt.t +end + (** Names for stores. *) module type NAME = sig val name : string @@ -178,6 +192,18 @@ module Make_indexed_file and type value := V.t and type header := V.Header.t +module Make_simple_indexed_file + (_ : NAME) + (K : Index.Key.S) (V : sig + include ENCODABLE_VALUE_HEADER + + val header : t -> Header.t + end) : + SIMPLE_INDEXED_FILE + with type key := K.t + and type value := V.t + and type header := V.Header.t + (** {2 Helper functors} *) module Make_fixed_encodable (V : ENCODABLE_VALUE) : -- GitLab From f1f31a8e8bbd6af79d9ba24ca76eb86eaddf1b09 Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Thu, 8 Dec 2022 12:38:34 +0100 Subject: [PATCH 07/11] Layer2/Store: improve documentation --- src/lib_layer2_store/indexed_store.mli | 41 ++++++++++++++++++-------- 1 file changed, 29 insertions(+), 12 deletions(-) diff --git a/src/lib_layer2_store/indexed_store.mli b/src/lib_layer2_store/indexed_store.mli index fc03c43ffb7d..d52717f96354 100644 --- a/src/lib_layer2_store/indexed_store.mli +++ b/src/lib_layer2_store/indexed_store.mli @@ -23,13 +23,24 @@ (* *) (*****************************************************************************) -(** Describes the different representations that can be stored persistently. *) +(** This library provides functors to build various kinds of stores using + mirage's {{:https://github.com/mirage/index} index}} and Octez + {{:https://gitlab.com/nomadic-labs/data-encoding} data-encoding} + libraries. + + It is tailored to build stores for the Layer 2 nodes of Tezos (Tx-rollups + and Smart rollups). + + The stores built with this library support concurrent accesses thanks to the + use of the light scheduler provided by {!Lwt_idle_waiter} for exclusive + write access. *) open Store_sigs (** {2 Signatures} *) -(** A store composed of a single file on disk *) +(** A store for single updatable values. Values are stored in a file on disk and + are kept in memory in a cache. *) module type SINGLETON_STORE = sig (** The type of the singleton store. *) type +'a t @@ -51,15 +62,15 @@ module type SINGLETON_STORE = sig val delete : [> `Write] t -> unit tzresult Lwt.t end -(** An index store mapping keys to values. It is composed of an index only. *) +(** An index store mapping keys to values. It uses an index file internally. *) module type INDEXABLE_STORE = sig - (** The type of store build in indexes *) + (** The type of store built on indexes. *) type +'a t - (** The type of keys for the *) + (** The type of keys for the store. *) type key - (** The type of values stored in the index *) + (** The type of values stored in the index, *) type value (** Load (or initializes) a store in the file [path]. If [readonly] is [true], @@ -79,7 +90,8 @@ module type INDEXABLE_STORE = sig right away. *) val add : ?flush:bool -> [> `Write] t -> key -> value -> unit tzresult Lwt.t - (** Closes the store. After this call the store cannot be accessed anymore. *) + (** Closes the store. After this call the store cannot be accessed anymore + (unless one calls {!load} again). *) val close : _ t -> unit tzresult Lwt.t end @@ -93,13 +105,17 @@ module type INDEXABLE_REMOVABLE_STORE = sig val remove : ?flush:bool -> [> `Write] t -> key -> unit tzresult Lwt.t end -(** An indexed file (i.e. a file and an index) mapping keys to values. The - values can vary in size. *) +(** An indexed file (i.e. a file and an index) mapping keys to values. Contrary + to {!INDEXABLE_STORE}, the values can vary in size. Internally, values are + stored, concatenated, in a append only file. The index file associates keys + to offsets in this file (and a header to retrieve information more + efficiently). +*) module type INDEXED_FILE = sig - (** The type of indexed file store *) + (** The type of indexed file store. *) type +'a t - (** The type of keys *) + (** The type of keys for the store. *) type key (** The type of headers stored in the index. The header can contain fixed size @@ -131,7 +147,8 @@ module type INDEXED_FILE = sig (** Loads a new or existing indexed file store in the directory [path]. *) val load : path:string -> cache_size:int -> 'a mode -> 'a t tzresult Lwt.t - (** Close the index and the file. *) + (** Close the index and the file. One must call {!load} again to read or write + data in the store. *) val close : _ t -> unit tzresult Lwt.t end -- GitLab From 7cea24c235c59305990e4963ba116bba877aea18 Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Thu, 8 Dec 2022 22:15:49 +0100 Subject: [PATCH 08/11] Layer2/Store: read only functions for indexed stores --- src/lib_layer2_store/indexed_store.ml | 14 +++++++++++++- src/lib_layer2_store/indexed_store.mli | 9 +++++++++ 2 files changed, 22 insertions(+), 1 deletion(-) diff --git a/src/lib_layer2_store/indexed_store.ml b/src/lib_layer2_store/indexed_store.ml index d9b135d488ae..37d2064e4930 100644 --- a/src/lib_layer2_store/indexed_store.ml +++ b/src/lib_layer2_store/indexed_store.ml @@ -133,6 +133,8 @@ module type SINGLETON_STORE = sig val write : [> `Write] t -> value -> unit tzresult Lwt.t val delete : [> `Write] t -> unit tzresult Lwt.t + + val readonly : [> `Read] t -> [`Read] t end module type INDEXABLE_STORE = sig @@ -151,6 +153,8 @@ module type INDEXABLE_STORE = sig val add : ?flush:bool -> [> `Write] t -> key -> value -> unit tzresult Lwt.t val close : _ t -> unit tzresult Lwt.t + + val readonly : [> `Read] t -> [`Read] t end module type INDEXABLE_REMOVABLE_STORE = sig @@ -185,6 +189,8 @@ module type INDEXED_FILE = sig val load : path:string -> cache_size:int -> 'a mode -> 'a t tzresult Lwt.t val close : _ t -> unit tzresult Lwt.t + + val readonly : [> `Read] t -> [`Read] t end module type SIMPLE_INDEXED_FILE = sig @@ -312,6 +318,8 @@ module Make_indexable (N : NAME) (K : Index.Key.S) (V : Index.Value.S) = struct Lwt_idle_waiter.force_idle store.scheduler @@ fun () -> (try I.close store.index with Index.Closed -> ()) ; return_unit + + let readonly x = (x :> [`Read] t) end module Make_indexable_removable (N : NAME) (K : Index.Key.S) (V : Index.Value.S) = @@ -384,7 +392,7 @@ module Make_singleton (S : sig val encoding : t Data_encoding.t end) : SINGLETON_STORE with type value := S.t = struct - type 'a t = {file : string; mutable cache : S.t option option} + type +'a t = {file : string; mutable cache : S.t option option} let read_disk store = let open Lwt_result_syntax in @@ -450,6 +458,8 @@ end) : SINGLETON_STORE with type value := S.t = struct @@ fun () -> let*! () = Lwt_utils_unix.create_dir (Filename.dirname path) in return {file = path; cache = None} + + let readonly x = (x :> [`Read] t) end module Make_indexed_file @@ -628,6 +638,8 @@ struct Lwt_idle_waiter.force_idle store.scheduler @@ fun () -> (try Header_index.close store.index with Index.Closed -> ()) ; Lwt_utils_unix.safe_close store.fd + + let readonly x = (x :> [`Read] t) end module Make_simple_indexed_file diff --git a/src/lib_layer2_store/indexed_store.mli b/src/lib_layer2_store/indexed_store.mli index d52717f96354..aef36b9628b0 100644 --- a/src/lib_layer2_store/indexed_store.mli +++ b/src/lib_layer2_store/indexed_store.mli @@ -60,6 +60,9 @@ module type SINGLETON_STORE = sig (** Deletes the value from the disk. *) val delete : [> `Write] t -> unit tzresult Lwt.t + + (** [readonly t] returns a read only version of the store [t]. *) + val readonly : [> `Read] t -> [`Read] t end (** An index store mapping keys to values. It uses an index file internally. *) @@ -93,6 +96,9 @@ module type INDEXABLE_STORE = sig (** Closes the store. After this call the store cannot be accessed anymore (unless one calls {!load} again). *) val close : _ t -> unit tzresult Lwt.t + + (** [readonly t] returns a read only version of the store [t]. *) + val readonly : [> `Read] t -> [`Read] t end (** An index store mapping keys to values. Keys are associated to optional @@ -150,6 +156,9 @@ module type INDEXED_FILE = sig (** Close the index and the file. One must call {!load} again to read or write data in the store. *) val close : _ t -> unit tzresult Lwt.t + + (** [readonly t] returns a read only version of the store [t]. *) + val readonly : [> `Read] t -> [`Read] t end (** Same as {!INDEXED_FILE} but where headers are extracted from values. *) -- GitLab From a42db37a8792bbc5cd0ac730c96e0f6f2c93edae Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Fri, 9 Dec 2022 11:43:01 +0100 Subject: [PATCH 09/11] Layer2/Store: return also header when reading from index file --- src/lib_layer2_store/indexed_store.ml | 10 +++++----- src/lib_layer2_store/indexed_store.mli | 4 ++-- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/lib_layer2_store/indexed_store.ml b/src/lib_layer2_store/indexed_store.ml index 37d2064e4930..e530dee7b80e 100644 --- a/src/lib_layer2_store/indexed_store.ml +++ b/src/lib_layer2_store/indexed_store.ml @@ -176,7 +176,7 @@ module type INDEXED_FILE = sig val header : [> `Read] t -> key -> header option tzresult Lwt.t - val read : [> `Read] t -> key -> value option tzresult Lwt.t + val read : [> `Read] t -> key -> (value * header) option tzresult Lwt.t val append : ?flush:bool -> @@ -534,7 +534,7 @@ struct index : Header_index.t; fd : Lwt_unix.file_descr; scheduler : Lwt_idle_waiter.t; - cache : V.t tzresult Cache.t; + cache : (V.t * V.Header.t) tzresult Cache.t; } (* The log_size corresponds to the maximum size of the memory zone @@ -570,9 +570,9 @@ struct let open Lwt_syntax in match Header_index.find store.index key with | exception Not_found -> Lwt.return_none - | {IHeader.offset; _} -> + | {IHeader.offset; header} -> let+ value = Values_file.pread_value store.fd ~file_offset:offset in - Some (Result.map fst value) + Some (Result.map (fun (value, _ofs) -> (value, header)) value) in let open Lwt_result_syntax in Cache.bind_or_put store.cache key read_from_disk @@ function @@ -601,7 +601,7 @@ struct @@ fun () -> let open Lwt_result_syntax in Lwt_idle_waiter.force_idle store.scheduler @@ fun () -> - Cache.put store.cache key (Lwt.return_some (Ok value)) ; + Cache.put store.cache key (Lwt.return_some (Ok (value, header))) ; let*! offset = Lwt_unix.lseek store.fd 0 Unix.SEEK_END in let*! _written_len = locked_write_value store ~offset ~value ~key ~header in if flush then Header_index.flush store.index ; diff --git a/src/lib_layer2_store/indexed_store.mli b/src/lib_layer2_store/indexed_store.mli index aef36b9628b0..d8e168b1b6fc 100644 --- a/src/lib_layer2_store/indexed_store.mli +++ b/src/lib_layer2_store/indexed_store.mli @@ -138,8 +138,8 @@ module type INDEXED_FILE = sig (** Returns the header for a key if it exists in the store. *) val header : [> `Read] t -> key -> header option tzresult Lwt.t - (** Read a full value from the indexed file store. *) - val read : [> `Read] t -> key -> value option tzresult Lwt.t + (** Read a full value and header from the indexed file store. *) + val read : [> `Read] t -> key -> (value * header) option tzresult Lwt.t (** Append a new binding to the indexed file store. *) val append : -- GitLab From f502338886c023572b1ff5f99a47ad2b1f0c093b Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Fri, 20 Jan 2023 13:45:30 +0100 Subject: [PATCH 10/11] Tests: property based tests for indexed store The properties checked are: - no errors - read value is the same as the last written one - resulting store agrees with equivalent hash table - reloading values from disk agrees with version with cache --- manifest/main.ml | 13 + opam/tezos-layer2-store.opam | 3 + src/lib_layer2_store/test/dune | 20 + .../test/test_indexed_store.ml | 494 ++++++++++++++++++ 4 files changed, 530 insertions(+) create mode 100644 src/lib_layer2_store/test/dune create mode 100644 src/lib_layer2_store/test/test_indexed_store.ml diff --git a/manifest/main.ml b/manifest/main.ml index a09185366d7c..650a76d44c9b 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -3194,6 +3194,19 @@ let octez_layer2_store = ] ~linkall:true +let _octez_layer2_indexed_store_test = + test + "test_indexed_store" + ~path:"src/lib_layer2_store/test/" + ~opam:"tezos-layer2-store" + ~deps: + [ + octez_error_monad |> open_ |> open_ ~m:"TzLwtreslib"; + octez_layer2_store |> open_; + qcheck_alcotest; + alcotest_lwt; + ] + let octez_dal_node_services = private_lib "tezos_dal_node_services" diff --git a/opam/tezos-layer2-store.opam b/opam/tezos-layer2-store.opam index 10d8e511d3d9..870cd410cbe6 100644 --- a/opam/tezos-layer2-store.opam +++ b/opam/tezos-layer2-store.opam @@ -16,6 +16,9 @@ depends: [ "aches-lwt" { >= "1.0.0" } "tezos-stdlib-unix" "tezos-context" + "tezos-error-monad" {with-test} + "qcheck-alcotest" { with-test & >= "0.20" } + "alcotest-lwt" { with-test & >= "1.5.0" } ] build: [ ["rm" "-r" "vendors"] diff --git a/src/lib_layer2_store/test/dune b/src/lib_layer2_store/test/dune new file mode 100644 index 000000000000..06dd4ff8daab --- /dev/null +++ b/src/lib_layer2_store/test/dune @@ -0,0 +1,20 @@ +; This file was automatically generated, do not edit. +; Edit file manifest/main.ml instead. + +(executable + (name test_indexed_store) + (libraries + tezos-error-monad + tezos_layer2_store + qcheck-alcotest + alcotest-lwt) + (flags + (:standard) + -open Tezos_error_monad + -open Tezos_error_monad.TzLwtreslib + -open Tezos_layer2_store)) + +(rule + (alias runtest) + (package tezos-layer2-store) + (action (run %{dep:./test_indexed_store.exe}))) diff --git a/src/lib_layer2_store/test/test_indexed_store.ml b/src/lib_layer2_store/test/test_indexed_store.ml new file mode 100644 index 000000000000..7ce3787b0a8d --- /dev/null +++ b/src/lib_layer2_store/test/test_indexed_store.ml @@ -0,0 +1,494 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2023 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. *) +(* *) +(*****************************************************************************) + +(* Testing + ------- + Component: Layer-2 indexed store + Invocation: dune exec src/lib_layer2_store/test/test_indexed_store.exe -- -v + Subject: Test the indexed store +*) + +(** The properties checked are: + - no errors + - read value is the same as the last written one + - resulting store agrees with equivalent hash table + - reloading values from disk agrees with version with cache +*) + +open Error_monad +open Store_sigs +open Indexed_store + +(** Signature for type equipped with a generator and a pretty printing + function. *) +module type GENERATABLE = sig + type t + + val gen : t QCheck2.Gen.t + + val pp : Format.formatter -> t -> unit +end + +(** Keys as strings of 32 characters used for tests *) +module SKey = struct + let size = 32 + + let name = "key_string_32" + + include Index.Key.String_fixed (struct + let length = size + end) + + let gen = + let open QCheck2.Gen in + let size_gen = pure size in + let gen = string_size ~gen:printable size_gen in + graft_corners gen [String.init size (fun _ -> '\000')] () + + let gen_distinct distinct_keys = QCheck2.Gen.list_repeat distinct_keys gen + + let pp fmt s = Format.fprintf fmt "%S" s + + let encoding = Data_encoding.Fixed.string size +end + +(** Used for singleton store tests which do not need keys. *) +module NoKey = struct + type t = unit + + let _name = "no_key" + + let gen = QCheck2.Gen.pure () + + let pp _ () = () +end + +(** Module to generate values for the stores, as unbounded byte sequences. *) +module Value = struct + type t = bytes + + let name = "bytes_value" + + let gen = QCheck2.Gen.bytes + + let pp fmt b = Hex.of_bytes b |> Hex.show |> Format.fprintf fmt "%S" + + let encoding = Data_encoding.bytes +end + +(** Module to generate fixed size values for the stores, byte sequences (of size + 500 here). *) +module FixedValue = struct + type t = bytes + + let size = 500 + + let name = "fixed_bytes_value_500" + + let gen = + let open QCheck2.Gen in + let size_gen = pure size in + bytes_size size_gen + + let pp = Value.pp + + let encoding = Data_encoding.Fixed.bytes size +end + +module Action (Key : GENERATABLE) (Value : GENERATABLE) = struct + (** Actions for a key-value store whose keys are [Key.t] and values are + [Value.t]. *) + type t = Write of Key.t * Value.t | Read of Key.t | Delete of Key.t + + (** Generator for actions. The parameter [no_delete] indicates if the + generator should generate delete actions or not, because some append-only + stores do not support delete. *) + let gen ?(no_delete = false) k_gen = + let open QCheck2.Gen in + let* k = k_gen in + let write = + let+ v = Value.gen in + Write (k, v) + in + let read = pure (Read k) in + let delete = pure (Delete k) in + let l = if no_delete then [read; write] else [read; write; delete] in + oneof l + + let _gen_for_key k = gen (QCheck2.Gen.pure k) + + let _gen_simple = gen Key.gen + + let pp fmt = function + | Write (k, v) -> Format.fprintf fmt "+ %a -> %a" Key.pp k Value.pp v + | Read k -> Format.fprintf fmt "%a ?" Key.pp k + | Delete k -> Format.fprintf fmt "- %a" Key.pp k +end + +(** A scenario is a list of actions. *) +module Scenario (Key : GENERATABLE) (Value : GENERATABLE) = struct + module Action = Action (Key) (Value) + + let gen ?no_delete keys = + let open QCheck2.Gen in + let key_gen = oneofl keys in + let size = frequency [(95, small_nat); (5, nat)] in + list_size size (Action.gen ?no_delete key_gen) + + let pp fmt = + Format.fprintf fmt "[@[ %a@ @]]" + @@ Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt " ;@ ") + Action.pp + + let print = Format.asprintf "%a" pp +end + +(* Because a scenario creates files onto the disk, we need a way to + generate unique names. For debugging purpose, and because of the + shrinking of QCheck2, it is easier to track tries with a simple + counter. *) +let uid = ref 0 + +(** This functor produces a [check_run] functions that plays a scenario and runs + checks on it. *) +module Runner + (Key : GENERATABLE) + (Value : GENERATABLE) (Store : sig + type t + + val load : path:string -> t tzresult Lwt.t + + val read : t -> Key.t -> Value.t option tzresult Lwt.t + + val write : t -> Key.t -> Value.t -> unit tzresult Lwt.t + + val delete : t -> Key.t -> unit tzresult Lwt.t + + val close : t -> unit tzresult Lwt.t + end) = +struct + module Scenario = Scenario (Key) (Value) + + module KeySet = Set.Make (struct + type t = Key.t + + let compare = Stdlib.compare + end) + + (** Retrieve the last written value from a list of executed actions (from + newest to oldest). *) + let rec last_written_value key = function + | [] -> None + | Scenario.Action.Delete k :: _ when k = key -> None + | Write (k, v) :: _ when k = key -> Some v + | _ :: executed -> last_written_value key executed + + let pp_opt_value = + Format.pp_print_option + ~none:(fun fmt () -> Format.pp_print_string fmt "[None]") + Value.pp + + let check_read_value_last_write key res executed = + let open Lwt_result_syntax in + let last = last_written_value key executed in + if res <> last then + failwith + "Read %a for key %a, but last wrote %a@." + pp_opt_value + res + Key.pp + key + pp_opt_value + last + else return_unit + + (** Checks that the value associated to [key] in the store is the last written + value is the list of executed actions. *) + let check_read_last_write store executed key = + let open Lwt_result_syntax in + let* res = Store.read store key in + check_read_value_last_write key res executed + + (** Checks that the store and the witness agree on the value associated to + [key] . *) + let check_store_agree_witness store witness key = + let open Lwt_result_syntax in + let* store_res = Store.read store key in + let witness_res = Stdlib.Hashtbl.find_opt witness key in + if store_res <> witness_res then + failwith + "Read %a from store for key %a, but hash table witness contains wrote \ + %a@." + pp_opt_value + store_res + Key.pp + key + pp_opt_value + witness_res + else return_unit + + let check_store_agree_witness store witness keys = + KeySet.iter_es (check_store_agree_witness store witness) keys + + let run scenario = + let open Lwt_result_syntax in + incr uid ; + (* To avoid any conflict with previous runs of this test. *) + let pid = Unix.getpid () in + let path = + Filename.(concat @@ get_temp_dir_name ()) + (Format.sprintf "tezos-layer2-indexed-store-test-%d-%d" pid !uid) + in + (* Use use a hash table as a witness for the result of our scenario. Each + action is performed both on the witness (in memory) and the real + store. *) + (* Actions on the real witness. *) + let witness = Stdlib.Hashtbl.create 9 in + let last_witness_read = ref None in + let run_witness_action = function + | Scenario.Action.Write (k, v) -> Stdlib.Hashtbl.replace witness k v + | Read k -> + let res = Stdlib.Hashtbl.find_opt witness k in + last_witness_read := res + | Delete k -> Stdlib.Hashtbl.remove witness k + in + (* Actions on the real store. *) + let* store = Store.load ~path in + let last_store_read = ref None in + let run_store_action executed = function + | Scenario.Action.Write (k, v) -> Store.write store k v + | Read k -> + let* res = Store.read store k in + last_store_read := res ; + check_read_value_last_write k res executed + | Delete k -> Store.delete store k + in + (* Inner loop to run actions. It returns the keys of the scenario and the + executed actions. *) + let rec run_actions keys executed = function + | [] -> return (keys, executed) + | a :: rest -> + run_witness_action a ; + let* () = run_store_action executed a in + let (Write (k, _) | Read k | Delete k) = a in + let keys = KeySet.add k keys in + run_actions keys (a :: executed) rest + in + let* keys, executed = run_actions KeySet.empty [] scenario in + (* Check that the read value is the last write for all keys at the end. *) + let* () = KeySet.iter_es (check_read_last_write store executed) keys in + (* Check that the store and witness agree at the end. *) + let* () = check_store_agree_witness store witness keys in + let* () = Store.close store in + (* To clear the caches (of the stores, etc.), we close and reopen it. We + then check that the version on disk still agrees with the witness. *) + let* store = Store.load ~path in + let* () = check_store_agree_witness store witness keys in + let* () = Store.close store in + return keys + + let check_run scenario = + let promise = + let open Lwt_result_syntax in + let* _ = run scenario in + return_true + in + match Lwt_main.run promise with + | Ok _ -> true + | Error err -> + QCheck2.Test.fail_reportf "%a@." Error_monad.pp_print_trace err +end + +let test_singleton = + let module Singleton_for_test = struct + module S = Make_singleton (Value) + + type t = rw S.t + + let load = S.load Read_write + + let read s () = S.read s + + let write s () v = S.write s v + + let delete s () = S.delete s + + let close _ = Lwt_result_syntax.return_unit + end in + let module R = Runner (NoKey) (Value) (Singleton_for_test) in + let open QCheck2 in + let test_gen = R.Scenario.gen [()] in + Test.make + ~print:R.Scenario.print + ~name:"singleton store" + ~count:2_000 + ~max_fail:1_000 (*to stop shrinking after [max_fail] failures. *) + test_gen + R.check_run + +let test_indexable = + let module Indexable_for_test = struct + module S = + Make_indexable + (struct + let name = "indexable_test" + end) + (SKey) + (Make_index_value (Make_fixed_encodable (FixedValue))) + + type t = rw S.t + + let load = S.load Read_write + + let read s k = S.find s k + + let write s k v = S.add s k v + + let delete _ _ = assert false + + let close = S.close + end in + let module R = Runner (SKey) (FixedValue) (Indexable_for_test) in + let open QCheck2 in + let test_gen = + let open Gen in + let* n = int_range 2 10 in + let* keys = SKey.gen_distinct n in + R.Scenario.gen ~no_delete:true keys + in + Test.make + ~print:R.Scenario.print + ~name:"indexable store" + ~count:2_000 + ~max_fail:1_000 (*to stop shrinking after [max_fail] failures. *) + test_gen + R.check_run + +let test_indexable_removable = + let module Indexable_for_test = struct + module S = + Make_indexable_removable + (struct + let name = "indexable_removable_test" + end) + (SKey) + (Make_index_value (Make_fixed_encodable (FixedValue))) + + type t = rw S.t + + let load = S.load Read_write + + let read s k = S.find s k + + let write s k v = S.add s k v + + let delete s k = S.remove s k + + let close = S.close + end in + let module R = Runner (SKey) (FixedValue) (Indexable_for_test) in + let open QCheck2 in + let test_gen = + let open Gen in + let* n = int_range 2 10 in + let* keys = SKey.gen_distinct n in + R.Scenario.gen keys + in + Test.make + ~print:R.Scenario.print + ~name:"indexable removable store" + ~count:2_000 + ~max_fail:1_000 (*to stop shrinking after [max_fail] failures. *) + test_gen + R.check_run + +let test_indexed_file = + let module Indexed_file_for_test = struct + module S = + Make_simple_indexed_file + (struct + let name = "indexed_file" + end) + (Make_index_key (struct + include Make_fixed_encodable (SKey) + + let equal = String.equal + end)) + (struct + include Value + + module Header = struct + type t = int32 + + let name = "sum_chars" + + let encoding = Data_encoding.int32 + + let fixed_size = 4 + end + + (* Header contains sum of byte codes as an example *) + let header b = + Bytes.fold_left (fun n c -> n + Char.code c) 0 b |> Int32.of_int + end) + + type t = rw S.t + + let load ~path = S.load ~path ~cache_size:10 Read_write + + open Lwt_result_syntax + + let read s k = + let+ v = S.read s k in + Option.map fst v + + let write s k v = S.append s ~key:k ~value:v + + let delete _ _ = assert false + + let close = S.close + end in + let module R = Runner (SKey) (Value) (Indexed_file_for_test) in + let open QCheck2 in + let test_gen = + let open Gen in + let* n = int_range 2 10 in + let* keys = SKey.gen_distinct n in + R.Scenario.gen ~no_delete:true keys + in + Test.make + ~print:R.Scenario.print + ~name:"indexed file store" + ~count:2_000 + ~max_fail:1_000 (*to stop shrinking after [max_fail] failures. *) + test_gen + R.check_run + +let () = + QCheck_base_runner.run_tests_main + [ + test_singleton; test_indexable; test_indexable_removable; test_indexed_file; + ] -- GitLab From ad733ca8db57fbca9f2278c4a5f98a6908c2c57e Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Fri, 20 Jan 2023 17:09:50 +0100 Subject: [PATCH 11/11] Tests: property based tests for concurrent accesses on indexed store --- .../test/test_indexed_store.ml | 244 +++++++++++++----- 1 file changed, 176 insertions(+), 68 deletions(-) diff --git a/src/lib_layer2_store/test/test_indexed_store.ml b/src/lib_layer2_store/test/test_indexed_store.ml index 7ce3787b0a8d..2846417609f9 100644 --- a/src/lib_layer2_store/test/test_indexed_store.ml +++ b/src/lib_layer2_store/test/test_indexed_store.ml @@ -145,23 +145,78 @@ module Action (Key : GENERATABLE) (Value : GENERATABLE) = struct | Write (k, v) -> Format.fprintf fmt "+ %a -> %a" Key.pp k Value.pp v | Read k -> Format.fprintf fmt "%a ?" Key.pp k | Delete k -> Format.fprintf fmt "- %a" Key.pp k + + let key (Write (k, _) | Read k | Delete k) = k + + let parallelizable_with action parallel_actions = + match action with + | Read k -> + (* Can be in parallel with other reads, and writes on other keys than k *) + List.for_all + (function Read _ -> true | Write (k', _) | Delete k' -> k <> k') + parallel_actions + | Write (k, _) | Delete k -> + (* Can be in parallel with actions on other keys *) + List.for_all (fun a -> key a <> k) parallel_actions end -(** A scenario is a list of actions. *) +(** A scenario is a parallelizable list of sequence of actions. Sequential tests + have only a single list. *) module Scenario (Key : GENERATABLE) (Value : GENERATABLE) = struct module Action = Action (Key) (Value) - let gen ?no_delete keys = + module KeyMap = Map.Make (struct + type t = Key.t + + let compare = Stdlib.compare + end) + + let gen_sequence ?no_delete keys = let open QCheck2.Gen in let key_gen = oneofl keys in let size = frequency [(95, small_nat); (5, nat)] in list_size size (Action.gen ?no_delete key_gen) + let gen_sequential ?no_delete keys = + let open QCheck2.Gen in + let+ sequence = gen_sequence ?no_delete keys in + List.map (fun a -> [a]) sequence + + let parallelize sequence = + let l = + List.fold_left + (fun acc action -> + match acc with + | parallel_actions :: previous + when Action.parallelizable_with action parallel_actions -> + (action :: parallel_actions) :: previous + | previous -> [action] :: previous) + [] + sequence + in + List.rev_map List.rev l + + let gen_parallel ?no_delete keys = + let open QCheck2.Gen in + let+ sequence = gen_sequence ?no_delete keys in + parallelize sequence + + let gen ?no_delete keys kind = + match kind with + | `Sequential -> gen_sequential ?no_delete keys + | `Parallel -> gen_parallel ?no_delete keys + + let pp_parallel fmt = + Format.fprintf fmt "[@[ %a@ @]]" + @@ Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt " ||@ ") + Action.pp + let pp fmt = Format.fprintf fmt "[@[ %a@ @]]" @@ Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt " ;@ ") - Action.pp + pp_parallel let print = Format.asprintf "%a" pp end @@ -253,6 +308,15 @@ struct let check_store_agree_witness store witness keys = KeySet.iter_es (check_store_agree_witness store witness) keys + (** Always close loaded stores to avoid leak when some tests fail. *) + let with_store path f = + let open Lwt_result_syntax in + let* store = Store.load ~path in + Lwt.finalize (fun () -> f store) @@ fun () -> + let open Lwt_syntax in + let* _ = Store.close store in + return_unit + let run scenario = let open Lwt_result_syntax in incr uid ; @@ -265,7 +329,7 @@ struct (* Use use a hash table as a witness for the result of our scenario. Each action is performed both on the witness (in memory) and the real store. *) - (* Actions on the real witness. *) + (* Actions on the hash table witness. *) let witness = Stdlib.Hashtbl.create 9 in let last_witness_read = ref None in let run_witness_action = function @@ -276,38 +340,46 @@ struct | Delete k -> Stdlib.Hashtbl.remove witness k in (* Actions on the real store. *) - let* store = Store.load ~path in - let last_store_read = ref None in - let run_store_action executed = function - | Scenario.Action.Write (k, v) -> Store.write store k v - | Read k -> - let* res = Store.read store k in - last_store_read := res ; - check_read_value_last_write k res executed - | Delete k -> Store.delete store k + let* keys = + with_store path @@ fun store -> + let last_store_read = ref None in + let run_store_action executed = function + | Scenario.Action.Write (k, v) -> Store.write store k v + | Read k -> + let* res = Store.read store k in + last_store_read := res ; + check_read_value_last_write k res executed + | Delete k -> Store.delete store k + in + (* Inner loop to run actions. It returns the keys of the scenario and the + executed actions. *) + let rec run_actions keys executed = function + | [] -> return (keys, executed) + | parallel_actions :: rest -> + List.iter run_witness_action parallel_actions ; + let* () = + List.iter_ep (run_store_action executed) parallel_actions + in + let keys = + KeySet.add_seq + (List.to_seq parallel_actions |> Seq.map Scenario.Action.key) + keys + in + run_actions keys (parallel_actions @ executed) rest + in + let* keys, executed = run_actions KeySet.empty [] scenario in + (* Check that the read value is the last write for all keys at the end. *) + let* () = KeySet.iter_es (check_read_last_write store executed) keys in + (* Check that the store and witness agree at the end. *) + let* () = check_store_agree_witness store witness keys in + return keys in - (* Inner loop to run actions. It returns the keys of the scenario and the - executed actions. *) - let rec run_actions keys executed = function - | [] -> return (keys, executed) - | a :: rest -> - run_witness_action a ; - let* () = run_store_action executed a in - let (Write (k, _) | Read k | Delete k) = a in - let keys = KeySet.add k keys in - run_actions keys (a :: executed) rest - in - let* keys, executed = run_actions KeySet.empty [] scenario in - (* Check that the read value is the last write for all keys at the end. *) - let* () = KeySet.iter_es (check_read_last_write store executed) keys in - (* Check that the store and witness agree at the end. *) - let* () = check_store_agree_witness store witness keys in - let* () = Store.close store in - (* To clear the caches (of the stores, etc.), we close and reopen it. We + (* Reload the store to clear the caches (of the stores, etc.). We then check that the version on disk still agrees with the witness. *) - let* store = Store.load ~path in - let* () = check_store_agree_witness store witness keys in - let* () = Store.close store in + let* () = + with_store path @@ fun store -> + check_store_agree_witness store witness keys + in return keys let check_run scenario = @@ -322,7 +394,30 @@ struct QCheck2.Test.fail_reportf "%a@." Error_monad.pp_print_trace err end -let test_singleton = +let tests = ref [] + +(** Small imperative helper to create test and register it, so we don't forget + one. *) +let register_test ?if_assumptions_fail ?count ?long_factor ?max_gen ?max_fail + ?retries ?name ?print ?collect ?stats get prop = + let t = + QCheck2.Test.make + ?if_assumptions_fail + ?count + ?long_factor + ?max_gen + ?max_fail + ?retries + ?name + ?print + ?collect + ?stats + get + prop + in + tests := t :: !tests + +let () = let module Singleton_for_test = struct module S = Make_singleton (Value) @@ -339,17 +434,16 @@ let test_singleton = let close _ = Lwt_result_syntax.return_unit end in let module R = Runner (NoKey) (Value) (Singleton_for_test) in - let open QCheck2 in let test_gen = R.Scenario.gen [()] in - Test.make + register_test ~print:R.Scenario.print - ~name:"singleton store" + ~name:"singleton store (sequential)" ~count:2_000 ~max_fail:1_000 (*to stop shrinking after [max_fail] failures. *) - test_gen + (test_gen `Sequential) R.check_run -let test_indexable = +let () = let module Indexable_for_test = struct module S = Make_indexable @@ -372,22 +466,28 @@ let test_indexable = let close = S.close end in let module R = Runner (SKey) (FixedValue) (Indexable_for_test) in - let open QCheck2 in - let test_gen = - let open Gen in + let test_gen kind = + let open QCheck2.Gen in let* n = int_range 2 10 in let* keys = SKey.gen_distinct n in - R.Scenario.gen ~no_delete:true keys + R.Scenario.gen ~no_delete:true keys kind in - Test.make + register_test + ~print:R.Scenario.print + ~name:"indexable store (sequential)" + ~count:2_000 + ~max_fail:1_000 (*to stop shrinking after [max_fail] failures. *) + (test_gen `Sequential) + R.check_run ; + register_test ~print:R.Scenario.print - ~name:"indexable store" + ~name:"indexable store (parallel)" ~count:2_000 ~max_fail:1_000 (*to stop shrinking after [max_fail] failures. *) - test_gen + (test_gen `Parallel) R.check_run -let test_indexable_removable = +let () = let module Indexable_for_test = struct module S = Make_indexable_removable @@ -410,22 +510,28 @@ let test_indexable_removable = let close = S.close end in let module R = Runner (SKey) (FixedValue) (Indexable_for_test) in - let open QCheck2 in - let test_gen = - let open Gen in + let test_gen kind = + let open QCheck2.Gen in let* n = int_range 2 10 in let* keys = SKey.gen_distinct n in - R.Scenario.gen keys + R.Scenario.gen keys kind in - Test.make + register_test + ~print:R.Scenario.print + ~name:"indexable removable store (sequential)" + ~count:2_000 + ~max_fail:1_000 (*to stop shrinking after [max_fail] failures. *) + (test_gen `Sequential) + R.check_run ; + register_test ~print:R.Scenario.print - ~name:"indexable removable store" + ~name:"indexable removable store (parallel)" ~count:2_000 ~max_fail:1_000 (*to stop shrinking after [max_fail] failures. *) - test_gen + (test_gen `Parallel) R.check_run -let test_indexed_file = +let () = let module Indexed_file_for_test = struct module S = Make_simple_indexed_file @@ -472,23 +578,25 @@ let test_indexed_file = let close = S.close end in let module R = Runner (SKey) (Value) (Indexed_file_for_test) in - let open QCheck2 in - let test_gen = - let open Gen in + let test_gen kind = + let open QCheck2.Gen in let* n = int_range 2 10 in let* keys = SKey.gen_distinct n in - R.Scenario.gen ~no_delete:true keys + R.Scenario.gen ~no_delete:true keys kind in - Test.make + register_test ~print:R.Scenario.print - ~name:"indexed file store" + ~name:"indexed file store (sequential)" ~count:2_000 ~max_fail:1_000 (*to stop shrinking after [max_fail] failures. *) - test_gen + (test_gen `Sequential) + R.check_run ; + register_test + ~print:R.Scenario.print + ~name:"indexed file store (parallel)" + ~count:2_000 + ~max_fail:1_000 (*to stop shrinking after [max_fail] failures. *) + (test_gen `Parallel) R.check_run -let () = - QCheck_base_runner.run_tests_main - [ - test_singleton; test_indexable; test_indexable_removable; test_indexed_file; - ] +let () = QCheck_base_runner.run_tests_main (List.rev !tests) -- GitLab