From 23b1612d541d8984898b5d22fb32e2b573d9bbd8 Mon Sep 17 00:00:00 2001 From: Ilias Garnier Date: Tue, 3 May 2022 18:55:20 +0200 Subject: [PATCH 01/11] lib_context: move disk impl of context to tezos-context.disk --- manifest/main.ml | 24 ++++-- src/lib_context/{ => disk}/context.ml | 0 src/lib_context/{ => disk}/context.mli | 0 src/lib_context/{ => disk}/context_dump.ml | 0 src/lib_context/{ => disk}/context_dump.mli | 0 .../{ => disk}/context_dump_intf.ml | 0 src/lib_context/disk/dune | 29 ++++++++ src/lib_context/disk/tezos_context_disk.ml | 74 +++++++++++++++++++ src/lib_context/dune | 23 +----- src/lib_context/memory/test/dune | 2 +- src/lib_context/memory/test/test.ml | 2 +- src/lib_context/test/dune | 8 +- src/lib_context/tezos_context.ml | 53 +------------ 13 files changed, 131 insertions(+), 84 deletions(-) rename src/lib_context/{ => disk}/context.ml (100%) rename src/lib_context/{ => disk}/context.mli (100%) rename src/lib_context/{ => disk}/context_dump.ml (100%) rename src/lib_context/{ => disk}/context_dump.mli (100%) rename src/lib_context/{ => disk}/context_dump_intf.ml (100%) create mode 100644 src/lib_context/disk/dune create mode 100644 src/lib_context/disk/tezos_context_disk.ml diff --git a/manifest/main.ml b/manifest/main.ml index 9f896bb1c020..700628e2978d 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -1487,11 +1487,11 @@ let tezos_context_memory = tezos_context_helpers; ] -let tezos_context = +let tezos_context_disk = public_lib - "tezos-context" - ~path:"src/lib_context" - ~synopsis:"Tezos: on-disk context abstraction for `tezos-node`" + "tezos-context.disk" + ~path:"src/lib_context/disk" + ~opam:"tezos-context" ~deps: [ tezos_shell_services |> open_; @@ -1511,6 +1511,13 @@ let tezos_context = tezos_context_memory; ] +let tezos_context = + public_lib + "tezos-context" + ~path:"src/lib_context" + ~synopsis:"Tezos: on-disk context abstraction for `tezos-node`" + ~deps:[tezos_context_disk; tezos_context_memory] + let _tezos_context_tests = test "test" @@ -1520,7 +1527,7 @@ let _tezos_context_tests = [ tezos_base |> open_ ~m:"TzPervasives"; tezos_base_unix; - tezos_context |> open_; + tezos_context_disk |> open_; tezos_stdlib_unix |> open_; tezos_test_helpers; tezos_test_helpers_extra; @@ -1537,7 +1544,7 @@ let _tezos_context_memory_tests = [ tezos_base |> open_ ~m:"TzPervasives"; tezos_base_unix; - tezos_context; + tezos_context_disk; tezos_context_memory; tezos_stdlib_unix |> open_; alcotest_lwt; @@ -2090,13 +2097,14 @@ let _tezos_context_merkle_proof_tests = [ tezos_base; tezos_base_unix; - tezos_context; + tezos_context_disk; tezos_context_encoding; tezos_stdlib_unix; qcheck_alcotest; tezos_test_helpers; ] - ~opens:["Tezos_base__TzPervasives"; "Tezos_context"; "Tezos_stdlib_unix"] + ~opens: + ["Tezos_base__TzPervasives"; "Tezos_context_disk"; "Tezos_stdlib_unix"] ~modules:["test_merkle_proof"] let tezos_validator_lib = diff --git a/src/lib_context/context.ml b/src/lib_context/disk/context.ml similarity index 100% rename from src/lib_context/context.ml rename to src/lib_context/disk/context.ml diff --git a/src/lib_context/context.mli b/src/lib_context/disk/context.mli similarity index 100% rename from src/lib_context/context.mli rename to src/lib_context/disk/context.mli diff --git a/src/lib_context/context_dump.ml b/src/lib_context/disk/context_dump.ml similarity index 100% rename from src/lib_context/context_dump.ml rename to src/lib_context/disk/context_dump.ml diff --git a/src/lib_context/context_dump.mli b/src/lib_context/disk/context_dump.mli similarity index 100% rename from src/lib_context/context_dump.mli rename to src/lib_context/disk/context_dump.mli diff --git a/src/lib_context/context_dump_intf.ml b/src/lib_context/disk/context_dump_intf.ml similarity index 100% rename from src/lib_context/context_dump_intf.ml rename to src/lib_context/disk/context_dump_intf.ml diff --git a/src/lib_context/disk/dune b/src/lib_context/disk/dune new file mode 100644 index 000000000000..1ab9aac88d8c --- /dev/null +++ b/src/lib_context/disk/dune @@ -0,0 +1,29 @@ +; This file was automatically generated, do not edit. +; Edit file manifest/main.ml instead. + +(library + (name tezos_context_disk) + (public_name tezos-context.disk) + (instrumentation (backend bisect_ppx)) + (libraries + tezos-shell-services + tezos-base + bigstringaf + fmt + logs.fmt + digestif.c + irmin + irmin-pack + irmin-pack.unix + tezos-stdlib-unix + tezos-stdlib + tezos-context.sigs + tezos-context.helpers + tezos-context.encoding + tezos-context.memory) + (flags + (:standard) + -open Tezos_shell_services + -open Tezos_base.TzPervasives + -open Tezos_stdlib_unix + -open Tezos_stdlib)) diff --git a/src/lib_context/disk/tezos_context_disk.ml b/src/lib_context/disk/tezos_context_disk.ml new file mode 100644 index 000000000000..eb8b6324ada8 --- /dev/null +++ b/src/lib_context/disk/tezos_context_disk.ml @@ -0,0 +1,74 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022-2022 Tarides *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Context comes with two variants: [Context] and [Context_binary] with + different tradeoffs. + + Both have different Merkle tree representations (i.e. when presented the + same data, they don't produce the same hashes). + + [lib_context] represents directories as a structured tree of inodes, instead + of a flat list of files, to get efficient copy-on-write and optimised read + patterns. + + The context variants differ by the branching factors used for these inode + trees: + + - [Context] uses a branching factor of 32; + - [Context_binary] uses a branching factor of 2. + + To represent a large directory, [Context] uses less but larger inodes than + [Context_binary]. + + As persisting inodes on disk have an overhead (i.e. the serialisation of an + inode is prefixed by its 32 byte hash), [Context] is thus optimised for + storing a large quantity of data on disk. + + On the opposite, as the inodes in Merkle proofs contain the hashes of the + shallow siblings, [Context_binary] is thus optimised for producing smaller + Merkle proofs. *) + +module Context_binary = struct + type error += + | Cannot_create_file = Context.Cannot_create_file + | Cannot_open_file = Context.Cannot_open_file + | Cannot_find_protocol = Context.Cannot_find_protocol + | Suspicious_file = Context.Suspicious_file + + include Context.Make (Tezos_context_encoding.Context_binary) +end + +(** The context of a tezos node. Persisted to disk. *) +module Context = struct + type error += + | Cannot_create_file = Context.Cannot_create_file + | Cannot_open_file = Context.Cannot_open_file + | Cannot_find_protocol = Context.Cannot_find_protocol + | Suspicious_file = Context.Suspicious_file + + include Context.Make (Tezos_context_encoding.Context) +end + +module Context_dump = Context_dump diff --git a/src/lib_context/dune b/src/lib_context/dune index 681666c7645c..317ffd31e7ef 100644 --- a/src/lib_context/dune +++ b/src/lib_context/dune @@ -6,24 +6,5 @@ (public_name tezos-context) (instrumentation (backend bisect_ppx)) (libraries - tezos-shell-services - tezos-base - bigstringaf - fmt - logs.fmt - digestif.c - irmin - irmin-pack - irmin-pack.unix - tezos-stdlib-unix - tezos-stdlib - tezos-context.sigs - tezos-context.helpers - tezos-context.encoding - tezos-context.memory) - (flags - (:standard) - -open Tezos_shell_services - -open Tezos_base.TzPervasives - -open Tezos_stdlib_unix - -open Tezos_stdlib)) + tezos-context.disk + tezos-context.memory)) diff --git a/src/lib_context/memory/test/dune b/src/lib_context/memory/test/dune index 115362e890be..3004c24aa335 100644 --- a/src/lib_context/memory/test/dune +++ b/src/lib_context/memory/test/dune @@ -6,7 +6,7 @@ (libraries tezos-base tezos-base.unix - tezos-context + tezos-context.disk tezos-context.memory tezos-stdlib-unix alcotest-lwt) diff --git a/src/lib_context/memory/test/test.ml b/src/lib_context/memory/test/test.ml index 0671909c9001..b3c030045b85 100644 --- a/src/lib_context/memory/test/test.ml +++ b/src/lib_context/memory/test/test.ml @@ -25,7 +25,7 @@ (* shell context *) module C = struct - include Tezos_context.Context + include Tezos_context_disk.Context (** Basic blocks *) diff --git a/src/lib_context/test/dune b/src/lib_context/test/dune index c5dac24ea71a..8888a6016ff7 100644 --- a/src/lib_context/test/dune +++ b/src/lib_context/test/dune @@ -6,7 +6,7 @@ (libraries tezos-base tezos-base.unix - tezos-context + tezos-context.disk tezos-stdlib-unix tezos-test-helpers tezos-test-helpers-extra @@ -14,7 +14,7 @@ (flags (:standard) -open Tezos_base.TzPervasives - -open Tezos_context + -open Tezos_context_disk -open Tezos_stdlib_unix) (modules test_context test)) @@ -28,7 +28,7 @@ (libraries tezos-base tezos-base.unix - tezos-context + tezos-context.disk tezos-context.encoding tezos-stdlib-unix qcheck-alcotest @@ -36,7 +36,7 @@ (flags (:standard) -open Tezos_base__TzPervasives - -open Tezos_context + -open Tezos_context_disk -open Tezos_stdlib_unix) (modules test_merkle_proof)) diff --git a/src/lib_context/tezos_context.ml b/src/lib_context/tezos_context.ml index eb8b6324ada8..3a3cd610c1c0 100644 --- a/src/lib_context/tezos_context.ml +++ b/src/lib_context/tezos_context.ml @@ -1,7 +1,7 @@ (*****************************************************************************) (* *) (* Open Source License *) -(* Copyright (c) 2022-2022 Tarides *) +(* Copyright (c) 2022 Nomadic Labs *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -23,52 +23,7 @@ (* *) (*****************************************************************************) -(** Context comes with two variants: [Context] and [Context_binary] with - different tradeoffs. +(* We re-export {!Tezos_context_disk} under the name [Tezos_context] so that + it is the default implementation one gets when opening this module. *) - Both have different Merkle tree representations (i.e. when presented the - same data, they don't produce the same hashes). - - [lib_context] represents directories as a structured tree of inodes, instead - of a flat list of files, to get efficient copy-on-write and optimised read - patterns. - - The context variants differ by the branching factors used for these inode - trees: - - - [Context] uses a branching factor of 32; - - [Context_binary] uses a branching factor of 2. - - To represent a large directory, [Context] uses less but larger inodes than - [Context_binary]. - - As persisting inodes on disk have an overhead (i.e. the serialisation of an - inode is prefixed by its 32 byte hash), [Context] is thus optimised for - storing a large quantity of data on disk. - - On the opposite, as the inodes in Merkle proofs contain the hashes of the - shallow siblings, [Context_binary] is thus optimised for producing smaller - Merkle proofs. *) - -module Context_binary = struct - type error += - | Cannot_create_file = Context.Cannot_create_file - | Cannot_open_file = Context.Cannot_open_file - | Cannot_find_protocol = Context.Cannot_find_protocol - | Suspicious_file = Context.Suspicious_file - - include Context.Make (Tezos_context_encoding.Context_binary) -end - -(** The context of a tezos node. Persisted to disk. *) -module Context = struct - type error += - | Cannot_create_file = Context.Cannot_create_file - | Cannot_open_file = Context.Cannot_open_file - | Cannot_find_protocol = Context.Cannot_find_protocol - | Suspicious_file = Context.Suspicious_file - - include Context.Make (Tezos_context_encoding.Context) -end - -module Context_dump = Context_dump +include Tezos_context_disk -- GitLab From 20ee46d9bbb7b809516ac51a3665c03c24d2b55c Mon Sep 17 00:00:00 2001 From: Ilias Garnier Date: Tue, 3 May 2022 19:42:58 +0200 Subject: [PATCH 02/11] lib_context: split context_dump off tezos-context.disk --- manifest/main.ml | 9 +++++++++ opam/tezos-context.opam | 4 ++-- src/lib_context/disk/context.ml | 1 + src/lib_context/disk/dune | 3 ++- src/lib_context/disk/tezos_context_disk.ml | 2 -- src/lib_context/{disk => dump}/context_dump.ml | 0 src/lib_context/{disk => dump}/context_dump.mli | 0 .../{disk => dump}/context_dump_intf.ml | 0 src/lib_context/dump/dune | 14 ++++++++++++++ 9 files changed, 28 insertions(+), 5 deletions(-) rename src/lib_context/{disk => dump}/context_dump.ml (100%) rename src/lib_context/{disk => dump}/context_dump.mli (100%) rename src/lib_context/{disk => dump}/context_dump_intf.ml (100%) create mode 100644 src/lib_context/dump/dune diff --git a/manifest/main.ml b/manifest/main.ml index 700628e2978d..6471b15696cb 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -1472,6 +1472,14 @@ let tezos_context_helpers = irmin_pack; ] +let tezos_context_dump = + public_lib + "tezos-context.dump" + ~path:"src/lib_context/dump" + ~opam:"tezos-context" + ~deps: + [tezos_base |> open_ ~m:"TzPervasives"; tezos_stdlib_unix |> open_; fmt] + let tezos_context_memory = public_lib "tezos-context.memory" @@ -1509,6 +1517,7 @@ let tezos_context_disk = tezos_context_helpers; tezos_context_encoding; tezos_context_memory; + tezos_context_dump; ] let tezos_context = diff --git a/opam/tezos-context.opam b/opam/tezos-context.opam index bd92b798b40d..5fda45c2420b 100644 --- a/opam/tezos-context.opam +++ b/opam/tezos-context.opam @@ -13,12 +13,12 @@ depends: [ "tezos-stdlib" "irmin" { >= "3.2.2" & < "3.3.0" } "irmin-pack" { >= "3.2.2" & < "3.3.0" } + "tezos-stdlib-unix" + "fmt" { >= "0.8.7" } "tezos-shell-services" "bigstringaf" { >= "0.2.0" } - "fmt" { >= "0.8.7" } "logs" "digestif" { >= "0.7.3" } - "tezos-stdlib-unix" "tezos-test-helpers" {with-test} "tezos-test-helpers-extra" {with-test} "alcotest-lwt" { with-test & >= "1.5.0" } diff --git a/src/lib_context/disk/context.ml b/src/lib_context/disk/context.ml index 8b2084fa6c2c..c8f7b1f7c821 100644 --- a/src/lib_context/disk/context.ml +++ b/src/lib_context/disk/context.ml @@ -1072,6 +1072,7 @@ module Make (Encoding : module type of Tezos_context_encoding.Context) = struct (* Context dumper *) + open Tezos_context_dump module Context_dumper = Context_dump.Make (Dumpable_context) module Context_dumper_legacy = Context_dump.Make_legacy (Dumpable_context) diff --git a/src/lib_context/disk/dune b/src/lib_context/disk/dune index 1ab9aac88d8c..8f25b62f89cd 100644 --- a/src/lib_context/disk/dune +++ b/src/lib_context/disk/dune @@ -20,7 +20,8 @@ tezos-context.sigs tezos-context.helpers tezos-context.encoding - tezos-context.memory) + tezos-context.memory + tezos-context.dump) (flags (:standard) -open Tezos_shell_services diff --git a/src/lib_context/disk/tezos_context_disk.ml b/src/lib_context/disk/tezos_context_disk.ml index eb8b6324ada8..ad01ede3c89e 100644 --- a/src/lib_context/disk/tezos_context_disk.ml +++ b/src/lib_context/disk/tezos_context_disk.ml @@ -70,5 +70,3 @@ module Context = struct include Context.Make (Tezos_context_encoding.Context) end - -module Context_dump = Context_dump diff --git a/src/lib_context/disk/context_dump.ml b/src/lib_context/dump/context_dump.ml similarity index 100% rename from src/lib_context/disk/context_dump.ml rename to src/lib_context/dump/context_dump.ml diff --git a/src/lib_context/disk/context_dump.mli b/src/lib_context/dump/context_dump.mli similarity index 100% rename from src/lib_context/disk/context_dump.mli rename to src/lib_context/dump/context_dump.mli diff --git a/src/lib_context/disk/context_dump_intf.ml b/src/lib_context/dump/context_dump_intf.ml similarity index 100% rename from src/lib_context/disk/context_dump_intf.ml rename to src/lib_context/dump/context_dump_intf.ml diff --git a/src/lib_context/dump/dune b/src/lib_context/dump/dune new file mode 100644 index 000000000000..8e02dd76fe8a --- /dev/null +++ b/src/lib_context/dump/dune @@ -0,0 +1,14 @@ +; This file was automatically generated, do not edit. +; Edit file manifest/main.ml instead. + +(library + (name tezos_context_dump) + (public_name tezos-context.dump) + (instrumentation (backend bisect_ppx)) + (libraries + tezos-base + tezos-stdlib-unix + fmt) + (flags (:standard + -open Tezos_base.TzPervasives + -open Tezos_stdlib_unix))) -- GitLab From ac5e96ef71167c6074385c25458ac224bb6d35dd Mon Sep 17 00:00:00 2001 From: Ilias Garnier Date: Tue, 3 May 2022 20:44:20 +0200 Subject: [PATCH 03/11] lib_context: factor unix-free module type away for future reuse --- manifest/main.ml | 8 +- opam/tezos-context.opam | 2 +- src/lib_context/disk/context.ml | 58 ++++++- src/lib_context/disk/context.mli | 187 +++------------------ src/lib_context/disk/tezos_context_disk.ml | 20 +-- src/lib_context/dump/dune | 6 +- src/lib_context/memory/context.ml | 6 +- src/lib_context/memory/context.mli | 3 +- src/lib_context/sigs/context.ml | 170 ++++++++++++++++++- src/lib_context/sigs/dune | 11 +- 10 files changed, 273 insertions(+), 198 deletions(-) diff --git a/manifest/main.ml b/manifest/main.ml index 6471b15696cb..6bdd563bb568 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -1430,7 +1430,13 @@ let tezos_context_sigs = public_lib "tezos-context.sigs" ~path:"src/lib_context/sigs" - ~deps:[tezos_base |> open_ ~m:"TzPervasives"; tezos_stdlib |> open_] + ~opam:"tezos-context" + ~deps: + [ + tezos_base |> open_ ~m:"TzPervasives"; + tezos_stdlib |> open_; + tezos_shell_services |> open_; + ] let tezos_scoru_wasm = public_lib diff --git a/opam/tezos-context.opam b/opam/tezos-context.opam index 5fda45c2420b..7e6b814abb1d 100644 --- a/opam/tezos-context.opam +++ b/opam/tezos-context.opam @@ -11,11 +11,11 @@ depends: [ "dune" { >= "3.0" } "tezos-base" "tezos-stdlib" + "tezos-shell-services" "irmin" { >= "3.2.2" & < "3.3.0" } "irmin-pack" { >= "3.2.2" & < "3.3.0" } "tezos-stdlib-unix" "fmt" { >= "0.8.7" } - "tezos-shell-services" "bigstringaf" { >= "0.2.0" } "logs" "digestif" { >= "0.7.3" } diff --git a/src/lib_context/disk/context.ml b/src/lib_context/disk/context.ml index c8f7b1f7c821..75c60d141056 100644 --- a/src/lib_context/disk/context.ml +++ b/src/lib_context/disk/context.ml @@ -85,6 +85,52 @@ let () = (function Suspicious_file e -> Some e | _ -> None) (fun e -> Suspicious_file e) +module type TEZOS_CONTEXT_UNIX = sig + type error += + | Cannot_create_file of string + | Cannot_open_file of string + | Cannot_find_protocol + | Suspicious_file of int + + include + Tezos_context_sigs.Context.TEZOS_CONTEXT + with type memory_context_tree := Tezos_context_memory.Context.tree + + (** Sync the context with disk. Only useful for read-only instances. + Does not fail when the context is not in read-only mode. *) + val sync : index -> unit Lwt.t + + val flush : t -> t Lwt.t + + (** {2 Context dumping} *) + + val dump_context : + index -> + Context_hash.t -> + fd:Lwt_unix.file_descr -> + on_disk:bool -> + progress_display_mode:Animation.progress_display_mode -> + int tzresult Lwt.t + + (** Rebuild a context from a given snapshot. *) + val restore_context : + index -> + expected_context_hash:Context_hash.t -> + nb_context_elements:int -> + fd:Lwt_unix.file_descr -> + legacy:bool -> + in_memory:bool -> + progress_display_mode:Animation.progress_display_mode -> + unit tzresult Lwt.t + + (** Offline integrity checking and statistics for contexts. *) + module Checks : sig + module Pack : Irmin_pack_unix.Checks.S + + module Index : Index.Checks.S + end +end + let reporter () = let report src level ~over k msgf = let k _ = @@ -202,6 +248,12 @@ let () = args module Make (Encoding : module type of Tezos_context_encoding.Context) = struct + type error += + | Cannot_create_file = Cannot_create_file + | Cannot_open_file = Cannot_open_file + | Cannot_find_protocol = Cannot_find_protocol + | Suspicious_file = Suspicious_file + open Encoding (** Tezos - Versioned (key x value) store (over Irmin) *) @@ -353,7 +405,11 @@ module Make (Encoding : module type of Tezos_context_encoding.Context) = struct type tree = Store.tree - type kinded_key = [`Node of Store.node_key | `Value of Store.contents_key] + type node_key = Store.node_key + + type value_key = Store.contents_key + + type kinded_key = [`Node of node_key | `Value of value_key] module Tree = Tezos_context_helpers.Context.Make_tree (Conf) (Store) include Tezos_context_helpers.Context.Make_config (Conf) diff --git a/src/lib_context/disk/context.mli b/src/lib_context/disk/context.mli index 46b5cf3a9d9a..9a5f51d59519 100644 --- a/src/lib_context/disk/context.mli +++ b/src/lib_context/disk/context.mli @@ -26,155 +26,30 @@ (* *) (*****************************************************************************) -type error += - | Cannot_create_file of string - | Cannot_open_file of string - | Cannot_find_protocol - | Suspicious_file of int +module type TEZOS_CONTEXT_UNIX = sig + type error += + | Cannot_create_file of string + | Cannot_open_file of string + | Cannot_find_protocol + | Suspicious_file of int -(** Tezos - Versioned, block indexed (key x value) store *) -module Make (Encoding : module type of Tezos_context_encoding.Context) : sig - (** {2 Generic interface} *) - - module type S = sig - (** @inline *) - include Tezos_context_sigs.Context.S - end - - (** A block-indexed (key x value) store directory. *) - type index - - include S with type index := index - - type context = t - - val index : context -> index - - (** Open or initialize a versioned store at a given path. - - @param indexing_strategy determines whether newly-exported objects by - this store handle should also be added to the store's index. [`Minimal] - (the default) only adds objects to the index when they are {i commits}, - whereas [`Always] indexes every object type. The indexing strategy used - for existing stores can be changed without issue (as only {i - newly}-exported objects are impacted). *) - val init : - ?patch_context:(context -> context tzresult Lwt.t) -> - ?readonly:bool -> - ?indexing_strategy:[`Always | `Minimal] -> - ?index_log_size:int -> - string -> - index Lwt.t - - (** Close the index. Does not fail when the context is already closed. *) - val close : index -> unit Lwt.t + include + Tezos_context_sigs.Context.TEZOS_CONTEXT + with type memory_context_tree := Tezos_context_memory.Context.tree (** Sync the context with disk. Only useful for read-only instances. - Does not fail when the context is not in read-only mode. *) + Does not fail when the context is not in read-only mode. *) val sync : index -> unit Lwt.t + (** An Irmin context corresponds to an in-memory overlay (corresponding + to the type {!tree}) over some on-disk data. Writes are buffered in + the overlay temporarily. Calling [flush] performs these writes on + disk and returns a context with an empty overlay. *) val flush : t -> t Lwt.t - val compute_testchain_chain_id : Block_hash.t -> Chain_id.t - - val compute_testchain_genesis : Block_hash.t -> Block_hash.t - - (** Build an empty context from an index. The resulting context should not - be committed. *) - val empty : index -> t - - (** Returns [true] if the context is empty. *) - val is_empty : t -> bool - - val commit_genesis : - index -> - chain_id:Chain_id.t -> - time:Time.Protocol.t -> - protocol:Protocol_hash.t -> - Context_hash.t tzresult Lwt.t - - val commit_test_chain_genesis : - context -> Block_header.t -> Block_header.t Lwt.t - - (** Extract a subtree from the {!Tezos_context.Context.t} argument and returns - it as a {!Tezos_context_memory.Context.tree} (note the the type change!). **) - val to_memory_tree : - t -> string list -> Tezos_context_memory.Context.tree option Lwt.t - - (** [merkle_tree t leaf_kind key] returns a Merkle proof for [key] (i.e. - whose hashes reach [key]). If [leaf_kind] is [Block_services.Hole], the value - at [key] is a hash. If [leaf_kind] is [Block_services.Raw_context], - the value at [key] is a [Block_services.raw_context]. Values higher - in the returned tree are hashes of the siblings on the path to - reach [key]. *) - val merkle_tree : - t -> - Block_services.merkle_leaf_kind -> - key -> - Block_services.merkle_tree Lwt.t - - (** {2 Accessing and Updating Versions} *) - - val exists : index -> Context_hash.t -> bool Lwt.t - - val checkout : index -> Context_hash.t -> context option Lwt.t - - val checkout_exn : index -> Context_hash.t -> context Lwt.t - - val hash : time:Time.Protocol.t -> ?message:string -> t -> Context_hash.t - - val commit : - time:Time.Protocol.t -> ?message:string -> context -> Context_hash.t Lwt.t - - val set_head : index -> Chain_id.t -> Context_hash.t -> unit Lwt.t - - val set_master : index -> Context_hash.t -> unit Lwt.t - - (** {2 Hash version} *) - - (** Get the hash version used for the context *) - val get_hash_version : context -> Context_hash.Version.t - - (** Set the hash version used for the context. It may recalculate the hashes - of the whole context, which can be a long process. - Returns an [Error] if the hash version is unsupported. *) - val set_hash_version : - context -> Context_hash.Version.t -> context tzresult Lwt.t - - (** {2 Predefined Fields} *) - - val get_protocol : context -> Protocol_hash.t Lwt.t - - val add_protocol : context -> Protocol_hash.t -> context Lwt.t - - val get_test_chain : context -> Test_chain_status.t Lwt.t - - val add_test_chain : context -> Test_chain_status.t -> context Lwt.t - - val remove_test_chain : context -> context Lwt.t - - val fork_test_chain : - context -> - protocol:Protocol_hash.t -> - expiration:Time.Protocol.t -> - context Lwt.t - - val clear_test_chain : index -> Chain_id.t -> unit Lwt.t - - val find_predecessor_block_metadata_hash : - context -> Block_metadata_hash.t option Lwt.t - - val add_predecessor_block_metadata_hash : - context -> Block_metadata_hash.t -> context Lwt.t - - val find_predecessor_ops_metadata_hash : - context -> Operation_metadata_list_list_hash.t option Lwt.t - - val add_predecessor_ops_metadata_hash : - context -> Operation_metadata_list_list_hash.t -> context Lwt.t - (** {2 Context dumping} *) + (** [dump_context] is used to export snapshots of the context at given hashes. *) val dump_context : index -> Context_hash.t -> @@ -194,34 +69,6 @@ module Make (Encoding : module type of Tezos_context_encoding.Context) : sig progress_display_mode:Animation.progress_display_mode -> unit tzresult Lwt.t - val retrieve_commit_info : - index -> - Block_header.t -> - (Protocol_hash.t - * string - * string - * Time.Protocol.t - * Test_chain_status.t - * Context_hash.t - * Block_metadata_hash.t option - * Operation_metadata_list_list_hash.t option - * Context_hash.t list) - tzresult - Lwt.t - - val check_protocol_commit_consistency : - expected_context_hash:Context_hash.t -> - given_protocol_hash:Protocol_hash.t -> - author:string -> - message:string -> - timestamp:Time.Protocol.t -> - test_chain_status:Test_chain_status.t -> - predecessor_block_metadata_hash:Block_metadata_hash.t option -> - predecessor_ops_metadata_hash:Operation_metadata_list_list_hash.t option -> - data_merkle_root:Context_hash.t -> - parents_contexts:Context_hash.t list -> - bool Lwt.t - (** Offline integrity checking and statistics for contexts. *) module Checks : sig module Pack : Irmin_pack_unix.Checks.S @@ -229,3 +76,7 @@ module Make (Encoding : module type of Tezos_context_encoding.Context) : sig module Index : Index.Checks.S end end + +(** Tezos - Versioned, block indexed (key x value) store *) +module Make (Encoding : module type of Tezos_context_encoding.Context) : + TEZOS_CONTEXT_UNIX diff --git a/src/lib_context/disk/tezos_context_disk.ml b/src/lib_context/disk/tezos_context_disk.ml index ad01ede3c89e..c42fb7455eea 100644 --- a/src/lib_context/disk/tezos_context_disk.ml +++ b/src/lib_context/disk/tezos_context_disk.ml @@ -50,23 +50,9 @@ shallow siblings, [Context_binary] is thus optimised for producing smaller Merkle proofs. *) -module Context_binary = struct - type error += - | Cannot_create_file = Context.Cannot_create_file - | Cannot_open_file = Context.Cannot_open_file - | Cannot_find_protocol = Context.Cannot_find_protocol - | Suspicious_file = Context.Suspicious_file +module type TEZOS_CONTEXT_UNIX = Context.TEZOS_CONTEXT_UNIX - include Context.Make (Tezos_context_encoding.Context_binary) -end +module Context_binary = Context.Make (Tezos_context_encoding.Context_binary) (** The context of a tezos node. Persisted to disk. *) -module Context = struct - type error += - | Cannot_create_file = Context.Cannot_create_file - | Cannot_open_file = Context.Cannot_open_file - | Cannot_find_protocol = Context.Cannot_find_protocol - | Suspicious_file = Context.Suspicious_file - - include Context.Make (Tezos_context_encoding.Context) -end +module Context = Context.Make (Tezos_context_encoding.Context) diff --git a/src/lib_context/dump/dune b/src/lib_context/dump/dune index 8e02dd76fe8a..bbfa8b28bc62 100644 --- a/src/lib_context/dump/dune +++ b/src/lib_context/dump/dune @@ -9,6 +9,6 @@ tezos-base tezos-stdlib-unix fmt) - (flags (:standard - -open Tezos_base.TzPervasives - -open Tezos_stdlib_unix))) + (flags (:standard) + -open Tezos_base.TzPervasives + -open Tezos_stdlib_unix)) diff --git a/src/lib_context/memory/context.ml b/src/lib_context/memory/context.ml index 7a17f9144272..8dfb589b36f0 100644 --- a/src/lib_context/memory/context.ml +++ b/src/lib_context/memory/context.ml @@ -33,7 +33,11 @@ module Make (Encoding : module type of Tezos_context_encoding.Context) = struct module Schema = Tezos_context_encoding.Context.Schema end - type kinded_key = [`Value of Context_hash.t | `Node of Context_hash.t] + type node_key = Context_hash.t + + type value_key = Context_hash.t + + type kinded_key = [`Value of value_key | `Node of node_key] module Kinded_key = struct let to_irmin_key (t : kinded_key) = diff --git a/src/lib_context/memory/context.mli b/src/lib_context/memory/context.mli index 0b8863189c2f..cefa4d71f4fb 100644 --- a/src/lib_context/memory/context.mli +++ b/src/lib_context/memory/context.mli @@ -31,7 +31,8 @@ module Make (Encoding : module type of Tezos_context_encoding.Context) : sig include Tezos_context_sigs.Context.S with type index := index - and type kinded_key = [`Value of Context_hash.t | `Node of Context_hash.t] + and type node_key = Context_hash.t + and type value_key = Context_hash.t val index : t -> index diff --git a/src/lib_context/sigs/context.ml b/src/lib_context/sigs/context.ml index 7a636de2698d..44647c54c439 100644 --- a/src/lib_context/sigs/context.ml +++ b/src/lib_context/sigs/context.ml @@ -411,10 +411,14 @@ module type S = sig (** The type for context repositories. *) type index + type node_key + + type value_key + (** The type of references to tree objects annotated with the type of that object (either a value or a node). Used to build a shallow tree with {!Tree.shallow} *) - type kinded_key + type kinded_key = [`Node of node_key | `Value of value_key] module Tree : sig include @@ -542,3 +546,167 @@ module type S = sig (** [verify_stream] is the verifier of stream proofs. *) val verify_stream_proof : (stream_proof, 'a) verifier end + +module type TEZOS_CONTEXT = sig + (** {2 Generic interface} *) + + module type S = sig + (** @inline *) + include S + end + + (** A block-indexed (key x value) store directory. *) + type index + + include S with type index := index + + type context = t + + type memory_context_tree + + val index : context -> index + + (** Open or initialize a versioned store at a given path. + + @param indexing_strategy determines whether newly-exported objects by + this store handle should also be added to the store's index. [`Minimal] + (the default) only adds objects to the index when they are {i commits}, + whereas [`Always] indexes every object type. The indexing strategy used + for existing stores can be changed without issue (as only {i + newly}-exported objects are impacted). *) + val init : + ?patch_context:(context -> context tzresult Lwt.t) -> + ?readonly:bool -> + ?indexing_strategy:[`Always | `Minimal] -> + ?index_log_size:int -> + string -> + index Lwt.t + + (** Close the index. Does not fail when the context is already closed. *) + val close : index -> unit Lwt.t + + val compute_testchain_chain_id : Block_hash.t -> Chain_id.t + + val compute_testchain_genesis : Block_hash.t -> Block_hash.t + + (** Build an empty context from an index. The resulting context should not + be committed. *) + val empty : index -> t + + (** Returns [true] if the context is empty. *) + val is_empty : t -> bool + + val commit_genesis : + index -> + chain_id:Chain_id.t -> + time:Time.Protocol.t -> + protocol:Protocol_hash.t -> + Context_hash.t tzresult Lwt.t + + val commit_test_chain_genesis : + context -> Block_header.t -> Block_header.t Lwt.t + + (** Extract a subtree from the {!Tezos_context.Context.t} argument and returns + it as a {!Tezos_context_memory.Context.tree} (note the the type change!). **) + val to_memory_tree : t -> string list -> memory_context_tree option Lwt.t + + (** [merkle_tree t leaf_kind key] returns a Merkle proof for [key] (i.e. + whose hashes reach [key]). If [leaf_kind] is [Block_services.Hole], the value + at [key] is a hash. If [leaf_kind] is [Block_services.Raw_context], + the value at [key] is a [Block_services.raw_context]. Values higher + in the returned tree are hashes of the siblings on the path to + reach [key]. *) + val merkle_tree : + t -> + Block_services.merkle_leaf_kind -> + key -> + Block_services.merkle_tree Lwt.t + + (** {2 Accessing and Updating Versions} *) + + val exists : index -> Context_hash.t -> bool Lwt.t + + val checkout : index -> Context_hash.t -> context option Lwt.t + + val checkout_exn : index -> Context_hash.t -> context Lwt.t + + val hash : time:Time.Protocol.t -> ?message:string -> t -> Context_hash.t + + val commit : + time:Time.Protocol.t -> ?message:string -> context -> Context_hash.t Lwt.t + + val set_head : index -> Chain_id.t -> Context_hash.t -> unit Lwt.t + + val set_master : index -> Context_hash.t -> unit Lwt.t + + (** {2 Hash version} *) + + (** Get the hash version used for the context *) + val get_hash_version : context -> Context_hash.Version.t + + (** Set the hash version used for the context. It may recalculate the hashes + of the whole context, which can be a long process. + Returns an [Error] if the hash version is unsupported. *) + val set_hash_version : + context -> Context_hash.Version.t -> context tzresult Lwt.t + + (** {2 Predefined Fields} *) + + val get_protocol : context -> Protocol_hash.t Lwt.t + + val add_protocol : context -> Protocol_hash.t -> context Lwt.t + + val get_test_chain : context -> Test_chain_status.t Lwt.t + + val add_test_chain : context -> Test_chain_status.t -> context Lwt.t + + val remove_test_chain : context -> context Lwt.t + + val fork_test_chain : + context -> + protocol:Protocol_hash.t -> + expiration:Time.Protocol.t -> + context Lwt.t + + val clear_test_chain : index -> Chain_id.t -> unit Lwt.t + + val find_predecessor_block_metadata_hash : + context -> Block_metadata_hash.t option Lwt.t + + val add_predecessor_block_metadata_hash : + context -> Block_metadata_hash.t -> context Lwt.t + + val find_predecessor_ops_metadata_hash : + context -> Operation_metadata_list_list_hash.t option Lwt.t + + val add_predecessor_ops_metadata_hash : + context -> Operation_metadata_list_list_hash.t -> context Lwt.t + + val retrieve_commit_info : + index -> + Block_header.t -> + (Protocol_hash.t + * string + * string + * Time.Protocol.t + * Test_chain_status.t + * Context_hash.t + * Block_metadata_hash.t option + * Operation_metadata_list_list_hash.t option + * Context_hash.t list) + tzresult + Lwt.t + + val check_protocol_commit_consistency : + expected_context_hash:Context_hash.t -> + given_protocol_hash:Protocol_hash.t -> + author:string -> + message:string -> + timestamp:Time.Protocol.t -> + test_chain_status:Test_chain_status.t -> + predecessor_block_metadata_hash:Block_metadata_hash.t option -> + predecessor_ops_metadata_hash:Operation_metadata_list_list_hash.t option -> + data_merkle_root:Context_hash.t -> + parents_contexts:Context_hash.t list -> + bool Lwt.t +end diff --git a/src/lib_context/sigs/dune b/src/lib_context/sigs/dune index 38c3365fb3fa..08e247590e90 100644 --- a/src/lib_context/sigs/dune +++ b/src/lib_context/sigs/dune @@ -7,7 +7,10 @@ (instrumentation (backend bisect_ppx)) (libraries tezos-base - tezos-stdlib) - (flags (:standard) - -open Tezos_base.TzPervasives - -open Tezos_stdlib)) + tezos-stdlib + tezos-shell-services) + (flags + (:standard) + -open Tezos_base.TzPervasives + -open Tezos_stdlib + -open Tezos_shell_services)) -- GitLab From 657bdba716299912fe201f9ee9d6d9f44a30455c Mon Sep 17 00:00:00 2001 From: Ilias Garnier Date: Wed, 4 May 2022 18:27:31 +0200 Subject: [PATCH 04/11] lib_context: let in-memory context implement TEZOS_CONTEXT --- manifest/main.ml | 1 + src/lib_context/disk/context.ml | 2 +- src/lib_context/memory/context.ml | 580 +++++++++++++++--- src/lib_context/memory/context.mli | 57 +- src/lib_context/memory/dune | 9 +- src/lib_context/memory/test/test.ml | 2 +- .../memory/tezos_context_memory.ml | 17 + src/lib_context/sigs/context.ml | 21 + .../memory_context.ml | 6 +- src/lib_protocol_environment/proxy_context.ml | 5 +- .../test_shell_context/test_proxy_context.ml | 3 +- src/lib_proxy/local_context.ml | 2 + src/lib_proxy/local_context.mli | 3 + .../integration/operations/test_tx_rollup.ml | 3 +- .../tx_rollup_benchmarks.ml | 3 +- .../integration/operations/test_tx_rollup.ml | 3 +- .../test/integration/test_sc_rollup_wasm.ml | 3 +- .../test/pbt/test_refutation_game.ml | 2 +- .../test/unit/test_sc_rollup_arith.ml | 3 +- 19 files changed, 566 insertions(+), 159 deletions(-) diff --git a/manifest/main.ml b/manifest/main.ml index 6bdd563bb568..e36f17f00f47 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -1494,6 +1494,7 @@ let tezos_context_memory = [ tezos_base |> open_ ~m:"TzPervasives"; tezos_stdlib |> open_; + tezos_shell_services |> open_; irmin_pack; irmin_pack_mem; tezos_context_sigs; diff --git a/src/lib_context/disk/context.ml b/src/lib_context/disk/context.ml index 75c60d141056..a13ffce34063 100644 --- a/src/lib_context/disk/context.ml +++ b/src/lib_context/disk/context.ml @@ -503,7 +503,7 @@ module Make (Encoding : module type of Tezos_context_encoding.Context) = struct ~uniq:`False ~contents tree - Tezos_context_memory.Context.(Tree.empty empty) + (Tezos_context_memory.make_empty_tree ()) let to_memory_tree (ctxt : t) (key : string list) : Tezos_context_memory.Context.tree option Lwt.t = diff --git a/src/lib_context/memory/context.ml b/src/lib_context/memory/context.ml index 8dfb589b36f0..ca5558939419 100644 --- a/src/lib_context/memory/context.ml +++ b/src/lib_context/memory/context.ml @@ -24,6 +24,24 @@ (* *) (*****************************************************************************) +module type TEZOS_CONTEXT_MEMORY = sig + type tree + + include + Tezos_context_sigs.Context.TEZOS_CONTEXT + with type memory_context_tree := tree + and type tree := tree + and type value_key = Context_hash.t + and type node_key = Context_hash.t + + (** Exception raised by [find_tree] and [add_tree] when applied to shallow + trees. It is exposed so that it can be catched by the proxy where such + operations on shallow trees are expected. *) + exception Context_dangling_hash of string + + val encoding : t Data_encoding.t +end + module Make (Encoding : module type of Tezos_context_encoding.Context) = struct open Encoding @@ -33,6 +51,9 @@ module Make (Encoding : module type of Tezos_context_encoding.Context) = struct module Schema = Tezos_context_encoding.Context.Schema end + module Info = Store.Info + module P = Store.Backend + type node_key = Context_hash.t type value_key = Context_hash.t @@ -62,33 +83,27 @@ module Make (Encoding : module type of Tezos_context_encoding.Context) = struct | Some h -> Some (Kinded_key.of_irmin_key h) end - include Tree - include Tezos_context_helpers.Context.Make_proof (Store) (Conf) - include Tezos_context_helpers.Context.Make_config (Conf) - - let produce_tree_proof t key = - produce_tree_proof - t - (match key with - | `Node hash -> `Node (Hash.of_context_hash hash) - | `Value hash -> `Value (Hash.of_context_hash hash)) - - let produce_stream_proof t key = - produce_stream_proof - t - (match key with - | `Node hash -> `Node (Hash.of_context_hash hash) - | `Value hash -> `Value (Hash.of_context_hash hash)) - - type index = Store.repo + type index = { + path : string; + (** [path] corresponds to the directory that Irmin considers to be + the root of the context. Specifying a root is mandatory, even + for in-memory contexts. Irmin might use this value to deduplicate + contexts sharing the same root. If several in-memory contexts + are to coexist in the same process, it might be wise to assign them + distinct roots. *) + repo : Store.repo; + patch_context : (t -> t tzresult Lwt.t) option; + } - type context = { - repo : index; + and context = { + index : index; parents : Store.Commit.t list; tree : Store.tree; } - type t = context + and t = context + + module type S = Tezos_context_sigs.Context.S type tree = Store.tree @@ -96,21 +111,35 @@ module Make (Encoding : module type of Tezos_context_encoding.Context) = struct type value = bytes - let index {repo; _} = repo + let index {index; _} = index + + (*-- Version Access and Update -----------------------------------------------*) + + let current_protocol_key = ["protocol"] + + let current_test_chain_key = ["test_chain"] + + let current_data_key = ["data"] + + let current_predecessor_block_metadata_hash_key = + ["predecessor_block_metadata_hash"] + + let current_predecessor_ops_metadata_hash_key = + ["predecessor_ops_metadata_hash"] - let exists index key = + let exists (index : index) key = let open Lwt_syntax in - let+ o = Store.Commit.of_hash index (Hash.of_context_hash key) in + let+ o = Store.Commit.of_hash index.repo (Hash.of_context_hash key) in Option.is_some o - let checkout index key = + let checkout (index : index) key = let open Lwt_syntax in - let* o = Store.Commit.of_hash index (Hash.of_context_hash key) in + let* o = Store.Commit.of_hash index.repo (Hash.of_context_hash key) in match o with | None -> Lwt.return_none | Some commit -> let tree = Store.Commit.tree commit in - let ctxt = {repo = index; tree; parents = [commit]} in + let ctxt = {index; tree; parents = [commit]} in Lwt.return_some ctxt let checkout_exn index key = @@ -124,17 +153,27 @@ module Make (Encoding : module type of Tezos_context_encoding.Context) = struct let unshallow context = let open Lwt_syntax in let* children = Store.Tree.list context.tree [] in - Store.Backend.Repo.batch context.repo (fun x y _ -> + Store.Backend.Repo.batch context.index.repo (fun x y _ -> List.iter_s (fun (s, k) -> match Store.Tree.destruct k with | `Contents _ -> Lwt.return () | `Node _ -> let* tree = Store.Tree.get_tree context.tree [s] in - let+ _ = Store.save_tree ~clear:true context.repo x y tree in + let+ _ = + Store.save_tree ~clear:true context.index.repo x y tree + in ()) children) + let get_hash_version _c = Context_hash.Version.of_int 0 + + let set_hash_version c v = + let open Lwt_result_syntax in + if Context_hash.Version.(of_int 0 = v) then return c + else + tzfail (Tezos_context_helpers.Context.Unsupported_context_hash_version v) + let raw_commit ~time ?(message = "") context = let open Lwt_syntax in let info = @@ -142,7 +181,7 @@ module Make (Encoding : module type of Tezos_context_encoding.Context) = struct in let parents = List.map Store.Commit.key context.parents in let* () = unshallow context in - let+ h = Store.Commit.v context.repo ~info ~parents context.tree in + let+ h = Store.Commit.v context.index.repo ~info ~parents context.tree in Store.Tree.clear context.tree ; h @@ -165,9 +204,12 @@ module Make (Encoding : module type of Tezos_context_encoding.Context) = struct (*-- Generic Store Primitives ------------------------------------------------*) - let data_key key = "data" :: key + let data_key key = current_data_key @ key + + let current_data_key = data_key [] - let mem ctxt key = Tree.mem ctxt.tree (data_key key) + let mem : t -> key -> bool Lwt.t = + fun ctxt key -> Tree.mem ctxt.tree (data_key key) let mem_tree ctxt key = Tree.mem_tree ctxt.tree (data_key key) @@ -202,62 +244,278 @@ module Make (Encoding : module type of Tezos_context_encoding.Context) = struct let fold ?depth ctxt key ~order ~init ~f = Tree.fold ?depth ctxt.tree (data_key key) ~order ~init ~f - let current_protocol_key = ["protocol"] + (** The light mode relies on the implementation of this + function, because it uses Irmin.Type.of_string to rebuild values + of type Irmin.Hash.t. This is a temporary workaround until we + do that in a type safe manner when there are less moving pieces. *) + let merkle_hash_to_string = Irmin.Type.to_string Store.Hash.t - let current_predecessor_block_metadata_hash_key = - ["predecessor_block_metadata_hash"] + let rec tree_to_raw_context tree = + let open Lwt_syntax in + match Store.Tree.destruct tree with + | `Contents (v, _) -> + let+ v = Store.Tree.Contents.force_exn v in + Block_services.Key v + | `Node _ -> + let* kvs = Store.Tree.list tree [] in + let f acc (key, _) = + (* get_tree is safe, because we iterate over keys *) + let* tree = Store.Tree.get_tree tree [key] in + let+ sub_raw_context = tree_to_raw_context tree in + String.Map.add key sub_raw_context acc + in + let+ res = List.fold_left_s f String.Map.empty kvs in + Block_services.Dir res - let current_predecessor_ops_metadata_hash_key = - ["predecessor_ops_metadata_hash"] + let to_memory_tree t key = find_tree t key + + let merkle_hash tree = + let merkle_hash_kind = + match Store.Tree.destruct tree with + | `Contents _ -> Block_services.Contents + | `Node _ -> Block_services.Node + in + let hash_str = Store.Tree.hash tree |> merkle_hash_to_string in + Block_services.Hash (merkle_hash_kind, hash_str) - let get_protocol ctxt = + let merkle_tree t leaf_kind key = let open Lwt_syntax in - let* o = Tree.find ctxt.tree current_protocol_key in - match o with - | None -> assert false - | Some data -> Lwt.return (Protocol_hash.of_bytes_exn data) + let* subtree_opt = Store.Tree.find_tree t.tree (data_key []) in + match subtree_opt with + | None -> Lwt.return String.Map.empty + | Some subtree -> + let key_to_string k = String.concat ";" k in + let rec key_to_merkle_tree t target = + match (Store.Tree.destruct t, target) with + | _, [] -> + (* We cannot use this case as the base case, because a merkle_node + is a map from string to something. In this case, we have + no key to put in the map's domain. *) + raise + (Invalid_argument + (Printf.sprintf "Reached end of key (top-level key was: %s)" + @@ key_to_string key)) + | _, [hd] -> + let finally key = + (* get_tree is safe because we iterate on keys *) + let* tree = Store.Tree.get_tree t [key] in + if key = hd then + (* on the target path: the final leaf *) + match leaf_kind with + | Block_services.Hole -> Lwt.return @@ merkle_hash tree + | Block_services.Raw_context -> + let+ raw_context = tree_to_raw_context tree in + Block_services.Data raw_context + else + (* a sibling of the target path: return a hash *) + Lwt.return @@ merkle_hash tree + in + let* l = Store.Tree.list t [] in + List.fold_left_s + (fun acc (key, _) -> + let+ v = finally key in + String.Map.add key v acc) + String.Map.empty + l + | `Node _, target_hd :: target_tl -> + let continue key = + (* get_tree is safe because we iterate on keys *) + let* tree = Store.Tree.get_tree t [key] in + if key = target_hd then + (* on the target path: recurse *) + let+ sub = key_to_merkle_tree tree target_tl in + Block_services.Continue sub + else + (* a sibling of the target path: return a hash *) + Lwt.return @@ merkle_hash tree + in + let* l = Store.Tree.list t [] in + List.fold_left_s + (fun acc (key, _) -> + let+ atom = continue key in + String.Map.add key atom acc) + String.Map.empty + l + | `Contents _, _ -> + raise + (Invalid_argument + (Printf.sprintf + "(`Contents _, l) when l <> [_] (in other words: found a \ + leaf node whereas key %s (top-level key: %s) wasn't \ + fully consumed)" + (key_to_string target) + (key_to_string key))) + in + key_to_merkle_tree subtree key - let add_protocol ctxt key = - let key = Protocol_hash.to_bytes key in - raw_add ctxt current_protocol_key key + exception Context_dangling_hash = Tree.Context_dangling_hash - let get_hash_version _c = Context_hash.Version.of_int 0 + include Tezos_context_helpers.Context.Make_proof (Store) (Conf) + include Tezos_context_helpers.Context.Make_config (Conf) - let set_hash_version c v = - let open Lwt_result_syntax in - if Context_hash.Version.(of_int 0 = v) then return c - else - tzfail (Tezos_context_helpers.Context.Unsupported_context_hash_version v) + let produce_tree_proof (t : index) key = + produce_tree_proof + t.repo + (match key with + | `Node hash -> `Node (Hash.of_context_hash hash) + | `Value hash -> `Value (Hash.of_context_hash hash)) - let add_predecessor_block_metadata_hash v hash = - let data = - Data_encoding.Binary.to_bytes_exn Block_metadata_hash.encoding hash - in - raw_add v current_predecessor_block_metadata_hash_key data + let produce_stream_proof (t : index) key = + produce_stream_proof + t.repo + (match key with + | `Node hash -> `Node (Hash.of_context_hash hash) + | `Value hash -> `Value (Hash.of_context_hash hash)) - let add_predecessor_ops_metadata_hash v hash = - let data = - Data_encoding.Binary.to_bytes_exn - Operation_metadata_list_list_hash.encoding - hash - in - raw_add v current_predecessor_ops_metadata_hash_key data + (*-- Predefined Fields -------------------------------------------------------*) + + module Root_tree = struct + let get_protocol t = + let open Lwt_syntax in + let+ o = Tree.find t current_protocol_key in + let data = + WithExceptions.Option.to_exn_f ~none:(fun () -> assert false) o + in + Protocol_hash.of_bytes_exn data + + let add_protocol t v = + let v = Protocol_hash.to_bytes v in + Tree.add t current_protocol_key v + + let get_test_chain t = + let open Lwt_syntax in + let* o = Tree.find t current_test_chain_key in + let data = + WithExceptions.Option.to_exn + ~none:(Failure "Unexpected error (Context.get_test_chain)") + o + in + match Data_encoding.Binary.of_bytes Test_chain_status.encoding data with + | Error re -> + Format.kasprintf + (fun s -> Lwt.fail (Failure s)) + "Error in Context.get_test_chain: %a" + Data_encoding.Binary.pp_read_error + re + | Ok r -> Lwt.return r + + let add_test_chain t id = + let id = + Data_encoding.Binary.to_bytes_exn Test_chain_status.encoding id + in + Tree.add t current_test_chain_key id + + let find_predecessor_block_metadata_hash t = + let open Lwt_syntax in + let* o = Tree.find t current_predecessor_block_metadata_hash_key in + match o with + | None -> return_none + | Some data -> ( + match + Data_encoding.Binary.of_bytes_opt Block_metadata_hash.encoding data + with + | None -> + raise + (Failure + "Unexpected error \ + (Context.get_predecessor_block_metadata_hash)") + | Some r -> return_some r) + + let add_predecessor_block_metadata_hash t hash = + let data = + Data_encoding.Binary.to_bytes_exn Block_metadata_hash.encoding hash + in + Tree.add t current_predecessor_block_metadata_hash_key data + + let find_predecessor_ops_metadata_hash t = + let open Lwt_syntax in + let* o = Tree.find t current_predecessor_ops_metadata_hash_key in + match o with + | None -> return_none + | Some data -> ( + match + Data_encoding.Binary.of_bytes_opt + Operation_metadata_list_list_hash.encoding + data + with + | None -> + raise + (Failure + "Unexpected error \ + (Context.get_predecessor_ops_metadata_hash)") + | Some r -> return_some r) + + let add_predecessor_ops_metadata_hash t hash = + let data = + Data_encoding.Binary.to_bytes_exn + Operation_metadata_list_list_hash.encoding + hash + in + Tree.add t current_predecessor_ops_metadata_hash_key data + end + + let get_protocol ctxt = Root_tree.get_protocol ctxt.tree + + let get_test_chain ctxt = Root_tree.get_test_chain ctxt.tree + + let find_predecessor_block_metadata_hash ctxt = + Root_tree.find_predecessor_block_metadata_hash ctxt.tree - let create () = + let find_predecessor_ops_metadata_hash ctxt = + Root_tree.find_predecessor_ops_metadata_hash ctxt.tree + + let lift_tree_add_to_ctxt tree_add ctxt v = let open Lwt_syntax in - let cfg = Irmin_pack.config "/tmp" in - let promise = - let* repo = Store.Repo.v cfg in - Lwt.return {repo; parents = []; tree = Store.Tree.empty ()} - in - match Lwt.state promise with - | Lwt.Return result -> result - | Lwt.Fail exn -> raise exn - | Lwt.Sleep -> - (* The in-memory context should never block *) - assert false + let+ tree = tree_add ctxt.tree v in + {ctxt with tree} + + let add_protocol = lift_tree_add_to_ctxt Root_tree.add_protocol + + let add_test_chain = lift_tree_add_to_ctxt Root_tree.add_test_chain + + let add_predecessor_block_metadata_hash = + lift_tree_add_to_ctxt Root_tree.add_predecessor_block_metadata_hash + + let add_predecessor_ops_metadata_hash = + lift_tree_add_to_ctxt Root_tree.add_predecessor_ops_metadata_hash + + let remove_test_chain v = raw_remove v current_test_chain_key + + let fork_test_chain v ~protocol ~expiration = + add_test_chain v (Forking {protocol; expiration}) + + let init ?patch_context ?(readonly = false) ?indexing_strategy ?index_log_size + path = + let open Lwt_syntax in + (* Note: we silently ignore the [indexing_strategy] and [index_log_size] arguments + but we could copy what the disk implementation is doing. *) + ignore indexing_strategy ; + ignore index_log_size ; + let cfg = Irmin_pack.config ~readonly path in + let* repo = Store.Repo.v cfg in + Lwt.return {path; repo; patch_context} + + let close index = Store.Repo.close index.repo + + let empty index = {index; parents = []; tree = Store.Tree.empty ()} + + let is_empty t = Tree.is_empty t.tree - let empty = create () + let get_branch chain_id = Format.asprintf "%a" Chain_id.pp chain_id + + let commit_genesis index ~chain_id ~time ~protocol = + let open Lwt_result_syntax in + let ctxt = empty index in + let* ctxt = + match index.patch_context with + | None -> return ctxt + | Some patch_context -> patch_context ctxt + in + let*! ctxt = add_protocol ctxt protocol in + let*! ctxt = add_test_chain ctxt Not_running in + let*! commit = raw_commit ~time ~message:"Genesis" ctxt in + let*! () = Store.Branch.set index.repo (get_branch chain_id) commit in + return (Hash.to_context_hash (Store.Commit.hash commit)) let concrete_encoding : Store.Tree.concrete Data_encoding.t = let open Data_encoding in @@ -291,28 +549,160 @@ module Make (Encoding : module type of Tezos_context_encoding.Context) = struct tree) (fun t -> let tree = Store.Tree.of_concrete t in - let ctxt = create () in + let index = + match Lwt.state (init "/tmp") with + | Lwt.Return result -> result + | Lwt.Fail exn -> raise exn + | Lwt.Sleep -> + (* The in-memory context should never block *) + assert false + in + let ctxt = empty index in {ctxt with tree}) concrete_encoding - let current_test_chain_key = ["test_chain"] + let compute_testchain_chain_id genesis = + let genesis_hash = Block_hash.hash_bytes [Block_hash.to_bytes genesis] in + Chain_id.of_block_hash genesis_hash + + let compute_testchain_genesis forked_block = + let genesis = Block_hash.hash_bytes [Block_hash.to_bytes forked_block] in + genesis - let get_test_chain v = + let commit_test_chain_genesis ctxt (forked_header : Block_header.t) = let open Lwt_syntax in - let* o = Tree.find v.tree current_test_chain_key in + let message = + Format.asprintf + "Forking testchain at level %ld." + forked_header.shell.level + in + let* commit = + raw_commit ~time:forked_header.shell.timestamp ~message ctxt + in + let faked_shell_header : Block_header.shell_header = + { + forked_header.shell with + proto_level = succ forked_header.shell.proto_level; + predecessor = Block_hash.zero; + validation_passes = 0; + operations_hash = Operation_list_list_hash.empty; + context = Hash.to_context_hash (Store.Commit.hash commit); + } + in + let forked_block = Block_header.hash forked_header in + let genesis_hash = compute_testchain_genesis forked_block in + let chain_id = compute_testchain_chain_id genesis_hash in + let genesis_header : Block_header.t = + { + shell = {faked_shell_header with predecessor = genesis_hash}; + protocol_data = Bytes.create 0; + } + in + let branch = get_branch chain_id in + let+ () = Store.Branch.set ctxt.index.repo branch commit in + genesis_header + + let clear_test_chain index chain_id = + (* TODO remove commits... ??? *) + (* TODO inherited from [lib_context/disk/context.ml] *) + let branch = get_branch chain_id in + Store.Branch.remove index.repo branch + + let set_head index chain_id commit = + let open Lwt_syntax in + let branch = get_branch chain_id in + let* o = Store.Commit.of_hash index.repo (Hash.of_context_hash commit) in match o with - | None -> Lwt.fail (Failure "Unexpected error (Context.get_test_chain)") - | Some data -> ( - match Data_encoding.Binary.of_bytes Test_chain_status.encoding data with - | Error re -> - Format.kasprintf - (fun s -> Lwt.fail (Failure s)) - "Error in Context.get_test_chain: %a" - Data_encoding.Binary.pp_read_error - re - | Ok r -> Lwt.return r) - - let add_test_chain v id = - let id = Data_encoding.Binary.to_bytes_exn Test_chain_status.encoding id in - raw_add v current_test_chain_key id + | None -> assert false + | Some commit -> Store.Branch.set index.repo branch commit + + let set_master index commit = + let open Lwt_syntax in + let* o = Store.Commit.of_hash index.repo (Hash.of_context_hash commit) in + match o with + | None -> assert false + | Some commit -> Store.Branch.set index.repo Store.Branch.main commit + + module Dumpable_context = struct + let context_parents ctxt = + match ctxt with + | {parents = [commit]; _} -> + let parents = Store.Commit.parents commit in + let parents = + List.map + (fun k -> P.Commit.Key.to_hash k |> Hash.to_context_hash) + parents + in + List.sort Context_hash.compare parents + | _ -> assert false + + let context_info = function + | {parents = [c]; _} -> Store.Commit.info c + | _ -> assert false + end + + let data_node_hash context = + let open Lwt_syntax in + let+ tree = Store.Tree.get_tree context.tree current_data_key in + Hash.to_context_hash (Store.Tree.hash tree) + + let retrieve_commit_info index block_header = + let open Lwt_syntax in + let* context = checkout_exn index block_header.Block_header.shell.context in + let irmin_info = Dumpable_context.context_info context in + let author = Info.author irmin_info in + let message = Info.message irmin_info in + let timestamp = Time.Protocol.of_seconds (Info.date irmin_info) in + let* protocol_hash = get_protocol context in + let* test_chain_status = get_test_chain context in + let* predecessor_block_metadata_hash = + find_predecessor_block_metadata_hash context + in + let* predecessor_ops_metadata_hash = + find_predecessor_ops_metadata_hash context + in + let* data_key = data_node_hash context in + let parents_contexts = Dumpable_context.context_parents context in + return_ok + ( protocol_hash, + author, + message, + timestamp, + test_chain_status, + data_key, + predecessor_block_metadata_hash, + predecessor_ops_metadata_hash, + parents_contexts ) + + let check_protocol_commit_consistency ~expected_context_hash + ~given_protocol_hash ~author ~message ~timestamp ~test_chain_status + ~predecessor_block_metadata_hash ~predecessor_ops_metadata_hash + ~data_merkle_root ~parents_contexts = + let open Lwt_syntax in + let data_merkle_root = Hash.of_context_hash data_merkle_root in + let parents = List.map Hash.of_context_hash parents_contexts in + let info = Info.v ~author (Time.Protocol.to_seconds timestamp) ~message in + let tree = Store.Tree.empty () in + let* tree = Root_tree.add_test_chain tree test_chain_status in + let* tree = Root_tree.add_protocol tree given_protocol_hash in + let* tree = + Option.fold + predecessor_block_metadata_hash + ~none:(Lwt.return tree) + ~some:(Root_tree.add_predecessor_block_metadata_hash tree) + in + let* tree = + Option.fold + predecessor_ops_metadata_hash + ~none:(Lwt.return tree) + ~some:(Root_tree.add_predecessor_ops_metadata_hash tree) + in + let data_t = Store.Tree.pruned (`Node data_merkle_root) in + let+ new_tree = Store.Tree.add_tree tree current_data_key data_t in + let node = Store.Tree.hash new_tree in + let ctxt_h = + P.Commit_portable.v ~info ~parents ~node + |> Commit_hash.hash |> Hash.to_context_hash + in + Context_hash.equal ctxt_h expected_context_hash end diff --git a/src/lib_context/memory/context.mli b/src/lib_context/memory/context.mli index cefa4d71f4fb..f7bf64f66eab 100644 --- a/src/lib_context/memory/context.mli +++ b/src/lib_context/memory/context.mli @@ -24,59 +24,24 @@ (* *) (*****************************************************************************) -(** Implementation of Tezos context fully in memory. *) -module Make (Encoding : module type of Tezos_context_encoding.Context) : sig - type index +module type TEZOS_CONTEXT_MEMORY = sig + type tree include - Tezos_context_sigs.Context.S - with type index := index - and type node_key = Context_hash.t + Tezos_context_sigs.Context.TEZOS_CONTEXT + with type memory_context_tree := tree + and type tree := tree and type value_key = Context_hash.t - - val index : t -> index - - val exists : index -> Context_hash.t -> bool Lwt.t - - val checkout : index -> Context_hash.t -> t option Lwt.t - - val checkout_exn : index -> Context_hash.t -> t Lwt.t - - val hash : time:Time.Protocol.t -> ?message:string -> t -> Context_hash.t - - val commit : - time:Time.Protocol.t -> ?message:string -> t -> Context_hash.t Lwt.t - - val create : unit -> t - - val empty : t - - val encoding : t Data_encoding.t - - val get_protocol : t -> Protocol_hash.t Lwt.t - - val add_protocol : t -> Protocol_hash.t -> t Lwt.t - - (** Get the hash version used for the context *) - val get_hash_version : t -> Context_hash.Version.t - - (** Set the hash version used for the context. It may recalculate the hashes - of the whole context, which can be a long process. - Returns an [Error] if the hash version is unsupported. *) - val set_hash_version : t -> Context_hash.Version.t -> t tzresult Lwt.t + and type node_key = Context_hash.t (** Exception raised by [find_tree] and [add_tree] when applied to shallow trees. It is exposed so that it can be catched by the proxy where such operations on shallow trees are expected. *) exception Context_dangling_hash of string - val add_predecessor_block_metadata_hash : - t -> Block_metadata_hash.t -> t Lwt.t - - val add_predecessor_ops_metadata_hash : - t -> Operation_metadata_list_list_hash.t -> t Lwt.t - - val get_test_chain : t -> Test_chain_status.t Lwt.t - - val add_test_chain : t -> Test_chain_status.t -> t Lwt.t + val encoding : t Data_encoding.t end + +(** Implementation of Tezos context fully in memory. *) +module Make (Encoding : module type of Tezos_context_encoding.Context) : + TEZOS_CONTEXT_MEMORY diff --git a/src/lib_context/memory/dune b/src/lib_context/memory/dune index a08f9892f6f4..3efc3f339ac8 100644 --- a/src/lib_context/memory/dune +++ b/src/lib_context/memory/dune @@ -8,11 +8,14 @@ (libraries tezos-base tezos-stdlib + tezos-shell-services irmin-pack irmin-pack.mem tezos-context.sigs tezos-context.encoding tezos-context.helpers) - (flags (:standard) - -open Tezos_base.TzPervasives - -open Tezos_stdlib)) + (flags + (:standard) + -open Tezos_base.TzPervasives + -open Tezos_stdlib + -open Tezos_shell_services)) diff --git a/src/lib_context/memory/test/test.ml b/src/lib_context/memory/test/test.ml index b3c030045b85..e031083e8aea 100644 --- a/src/lib_context/memory/test/test.ml +++ b/src/lib_context/memory/test/test.ml @@ -66,7 +66,7 @@ end module M = struct include Tezos_context_memory.Context - let make_context () = Lwt.return empty + let make_context () = Lwt.return (Tezos_context_memory.make_empty_context ()) end module Make (A : sig diff --git a/src/lib_context/memory/tezos_context_memory.ml b/src/lib_context/memory/tezos_context_memory.ml index b39353996386..d3d4c77b29ca 100644 --- a/src/lib_context/memory/tezos_context_memory.ml +++ b/src/lib_context/memory/tezos_context_memory.ml @@ -30,3 +30,20 @@ module Context_binary = Context.Make (Tezos_context_encoding.Context_binary) (** Variant of [Tezos_context.Context] purely in-memory. *) module Context = Context.Make (Tezos_context_encoding.Context) + +let make_empty_context ?(root = "/tmp") () = + let open Lwt_syntax in + let context_promise = + let+ index = Context.init root in + Context.empty index + in + match Lwt.state context_promise with + | Lwt.Return result -> result + | Lwt.Fail exn -> raise exn + | Lwt.Sleep -> + (* The in-memory context should never block *) + assert false + +let make_empty_tree = + let dummy_context = make_empty_context ~root:"dummy" () in + fun () -> Context.Tree.empty dummy_context diff --git a/src/lib_context/sigs/context.ml b/src/lib_context/sigs/context.ml index 44647c54c439..3f7d59564fb0 100644 --- a/src/lib_context/sigs/context.ml +++ b/src/lib_context/sigs/context.ml @@ -2,6 +2,7 @@ (* *) (* Open Source License *) (* Copyright (c) 2018-2021 Tarides *) +(* Copyright (c) 2022 Nomadic Labs *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -401,6 +402,14 @@ module type PROOF_ENCODING = sig val stream_proof_encoding : stream t Data_encoding.t end +(* TODO: https://gitlab.com/tezos/tezos/-/issues/2967 + + What is the purpose of module type [S]? + + [S] is morally the interface to the low-level storage visible to the + protocol. "Morally" because the exact module type expected by the protocol + is now defined to be {!Tezos_protocol_environment.Environment_context_intf.S}. +*) module type S = sig val equal_config : Config.t -> Config.t -> bool @@ -547,6 +556,15 @@ module type S = sig val verify_stream_proof : (stream_proof, 'a) verifier end +(** [TEZOS_CONTEXT] is the module type implemented by all storage + implementations. This is the module type that the {e shell} expects for its + operation. As such, it should be a strict superset of the interface exposed + to the protocol (see module type {!S} above and + {!Tezos_protocol_environment.Environment_context_intf.S}). + + The main purpose of this module type is to keep the on-disk and in-memory + implementations in sync. +*) module type TEZOS_CONTEXT = sig (** {2 Generic interface} *) @@ -562,6 +580,9 @@ module type TEZOS_CONTEXT = sig type context = t + (** [memory_context_tree] is a forward declaration of the type of + an in-memory Irmin tree. This type variable is to be substituted + by a concrete type wherever the {!TEZOS_CONTEXT} signature is used. *) type memory_context_tree val index : context -> index diff --git a/src/lib_protocol_environment/memory_context.ml b/src/lib_protocol_environment/memory_context.ml index 498f54f5ea9e..7828a3b47091 100644 --- a/src/lib_protocol_environment/memory_context.ml +++ b/src/lib_protocol_environment/memory_context.ml @@ -40,10 +40,6 @@ include Environment_context.Register (M) let impl_name = "memory" -let empty = - let ctxt = M.empty in - Context.make ~ops ~ctxt ~kind:Context ~equality_witness ~impl_name - let project : Context.t -> t = fun (Context.Context t) -> match t.kind with @@ -56,6 +52,8 @@ let project : Context.t -> t = let inject : t -> Context.t = fun ctxt -> Context.make ~ops ~ctxt ~kind:Context ~equality_witness ~impl_name +let empty = inject (Tezos_context_memory.make_empty_context ()) + let encoding : Context.t Data_encoding.t = let open Data_encoding in conv project inject M.encoding diff --git a/src/lib_protocol_environment/proxy_context.ml b/src/lib_protocol_environment/proxy_context.ml index 62f102732a0f..50f8b9f54756 100644 --- a/src/lib_protocol_environment/proxy_context.ml +++ b/src/lib_protocol_environment/proxy_context.ml @@ -36,7 +36,7 @@ module M = struct behave like [Memory_context]. *) type t = {proxy : Proxy_delegate.t option; local : Local.t} - let empty = Local.Tree.empty Local.empty + let empty = Tezos_context_memory.make_empty_tree () end module C = struct @@ -401,7 +401,8 @@ include Environment_context.Register (C) let proxy_impl_name = "proxy" let empty proxy = - let ctxt = M.{proxy; local = Local.empty} in + let local = Tezos_context_memory.make_empty_context () in + let ctxt = M.{proxy; local} in Context.make ~ops ~ctxt diff --git a/src/lib_protocol_environment/test_shell_context/test_proxy_context.ml b/src/lib_protocol_environment/test_shell_context/test_proxy_context.ml index d3401cc9aabf..22dc629ef26b 100644 --- a/src/lib_protocol_environment/test_shell_context/test_proxy_context.ml +++ b/src/lib_protocol_environment/test_shell_context/test_proxy_context.ml @@ -56,7 +56,8 @@ let key_to_string : String.t list -> String.t = String.concat ";" (* Initialize the Context before starting the tests *) let init_contexts (f : Context.t -> unit Lwt.t) _ () : 'a Lwt.t = let open Lwt_syntax in - let* ctxt = create_block Tezos_context_memory.Context.empty in + let ctxt = Tezos_context_memory.make_empty_context () in + let* ctxt = create_block ctxt in let proxy : Context.t = Proxy_context.empty (Some (Tezos_shell_context.Proxy_delegate_maker.of_memory_context ctxt)) diff --git a/src/lib_proxy/local_context.ml b/src/lib_proxy/local_context.ml index db4148e8ae88..5053b14ae0d1 100644 --- a/src/lib_proxy/local_context.ml +++ b/src/lib_proxy/local_context.ml @@ -26,6 +26,8 @@ include Tezos_context_memory.Context +let empty = Tezos_context_memory.make_empty_context () + let store_empty = empty let shallow_of_tree repo tree = diff --git a/src/lib_proxy/local_context.mli b/src/lib_proxy/local_context.mli index 35361f2b968f..58ac5a209601 100644 --- a/src/lib_proxy/local_context.mli +++ b/src/lib_proxy/local_context.mli @@ -27,3 +27,6 @@ include module type of Tezos_context_memory.Context (** [shallow_of_tree repo t] returns a shallow tree with the same hash as [t]. *) val shallow_of_tree : Tree.repo -> tree -> tree + +(** [empty] is an empty store. *) +val empty : t diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_tx_rollup.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_tx_rollup.ml index f2e40475264b..f220b980e85c 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_tx_rollup.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_tx_rollup.ml @@ -2235,7 +2235,8 @@ module Rejection = struct *) let init_l2_store () = let open Context.Syntax in - let store = C.empty in + let* index = C.init "/tmp" in + let store = C.empty index in let time = time () in let tree = C.Tree.empty store in let* tree = Prover_context.Address_index.init_counter tree in diff --git a/src/proto_alpha/lib_benchmarks_proto/tx_rollup_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/tx_rollup_benchmarks.ml index 37f9e9c08415..6afea8f679e9 100644 --- a/src/proto_alpha/lib_benchmarks_proto/tx_rollup_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/tx_rollup_benchmarks.ml @@ -336,7 +336,8 @@ let input ~rng_state nb_of_couple_addr nb_of_ticket_per_couple = let init_ctxt input = let open Prover_context in let open Syntax in - let empty_store = Irmin_context.empty in + let* index = Irmin_context.init "/tmp" in + let empty_store = Irmin_context.empty index in let empty_tree = Irmin_context.Tree.empty empty_store in let qty = Tx_rollup_l2_qty.of_int64_exn 1_000_000L in let* tree = diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_tx_rollup.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_tx_rollup.ml index 464deb25f90f..dda98827132d 100644 --- a/src/proto_alpha/lib_protocol/test/integration/operations/test_tx_rollup.ml +++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_tx_rollup.ml @@ -2248,7 +2248,8 @@ module Rejection = struct *) let init_l2_store () = let open L2_Context.Syntax in - let store = C.empty in + let* index = C.init "/tmp" in + let store = C.empty index in let time = time () in let tree = C.Tree.empty store in let* tree = Prover_context.Address_index.init_counter tree in diff --git a/src/proto_alpha/lib_protocol/test/integration/test_sc_rollup_wasm.ml b/src/proto_alpha/lib_protocol/test/integration/test_sc_rollup_wasm.ml index b4894197adb4..6959af79539a 100644 --- a/src/proto_alpha/lib_protocol/test/integration/test_sc_rollup_wasm.ml +++ b/src/proto_alpha/lib_protocol/test/integration/test_sc_rollup_wasm.ml @@ -111,7 +111,8 @@ module Prover = Alpha_context.Sc_rollup.Wasm_2_0_0PVM.Make (WASM_P) let should_boot () = let open Lwt_result_syntax in - let context = Context_binary.empty in + let*! index = Context_binary.init "/tmp" in + let context = Context_binary.empty index in let*! s = Prover.initial_state context "" in let*! s = Prover.eval s in let*! p_res = Prover.produce_proof context None s in diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml b/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml index 82b21eb03536..91d787b235d8 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml @@ -409,7 +409,7 @@ module TestArith (P : sig end) : TestPVM = struct include ContextPVM - let init_context = Tezos_context_memory.Context.empty + let init_context = Tezos_context_memory.make_empty_context () module Utils = struct let default_state = diff --git a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_arith.ml b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_arith.ml index d11a08ce0a9e..1838e469cbd6 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_arith.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_arith.ml @@ -101,7 +101,8 @@ open FullArithPVM let setup boot_sector f = let open Lwt_syntax in - let ctxt = Context_binary.empty in + let* index = Context_binary.init "/tmp" in + let ctxt = Context_binary.empty index in let* state = initial_state ctxt boot_sector in f ctxt state -- GitLab From a246645f189bd73d67d30436d0f349d0643ef131 Mon Sep 17 00:00:00 2001 From: Ilias Garnier Date: Thu, 5 May 2022 10:11:18 +0200 Subject: [PATCH 05/11] lib_protocol_env,lib_delegate: factor context_ops in lib_proto_env --- .gitlab/ci/opam-ci.yml | 9 +- dune-project | 1 + manifest/main.ml | 16 +++ opam/tezos-baking-012-Psithaca.opam | 1 + opam/tezos-baking-013-PtJakart.opam | 1 + opam/tezos-baking-alpha.opam | 1 + opam/tezos-context-ops.opam | 23 ++++ .../context_ops.ml | 32 ++++-- src/lib_protocol_environment/dune | 18 +++ src/proto_012_Psithaca/lib_delegate/dune | 2 + .../lib_delegate/context_ops.ml | 108 ------------------ src/proto_013_PtJakart/lib_delegate/dune | 2 + src/proto_alpha/lib_delegate/context_ops.ml | 108 ------------------ src/proto_alpha/lib_delegate/dune | 2 + 14 files changed, 96 insertions(+), 228 deletions(-) create mode 100644 opam/tezos-context-ops.opam rename src/{proto_012_Psithaca/lib_delegate => lib_protocol_environment}/context_ops.ml (84%) delete mode 100644 src/proto_013_PtJakart/lib_delegate/context_ops.ml delete mode 100644 src/proto_alpha/lib_delegate/context_ops.ml diff --git a/.gitlab/ci/opam-ci.yml b/.gitlab/ci/opam-ci.yml index 68981ddc3e57..38128fbe3ec6 100644 --- a/.gitlab/ci/opam-ci.yml +++ b/.gitlab/ci/opam-ci.yml @@ -571,6 +571,13 @@ opam:tezos-context: variables: package: tezos-context +opam:tezos-context-ops: + extends: + - .opam_template + - .rules_template__trigger_opam_batch_4 + variables: + package: tezos-context-ops + opam:tezos-crypto: extends: - .opam_template @@ -903,7 +910,7 @@ opam:tezos-protocol-006-PsCARTHA: opam:tezos-protocol-007-PsDELPH1: extends: - .opam_template - - .rules_template__trigger_opam_batch_4 + - .rules_template__trigger_opam_batch_5 variables: package: tezos-protocol-007-PsDELPH1 diff --git a/dune-project b/dune-project index aeb661f3e2aa..78cfbef38ef3 100644 --- a/dune-project +++ b/dune-project @@ -55,6 +55,7 @@ (package (name tezos-client-genesis)) (package (name tezos-codec)) (package (name tezos-context)) +(package (name tezos-context-ops)) (package (name tezos-crypto)) (package (name tezos-embedded-protocol-000-Ps9mPmXa)) (package (name tezos-embedded-protocol-001-PtCJ7pwo)) diff --git a/manifest/main.ml b/manifest/main.ml index e36f17f00f47..654265a2ece4 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -1796,6 +1796,21 @@ let _tezos_protocol_environment_tests = lwt_unix; ] +let tezos_context_ops = + public_lib + "tezos-context-ops" + ~path:"src/lib_protocol_environment" + ~synopsis:"Tezos: backend-agnostic operations on constexts" + ~deps: + [ + tezos_base |> open_ ~m:"TzPervasives"; + tezos_error_monad |> open_; + tezos_protocol_environment; + tezos_context |> open_; + tezos_shell_context |> open_; + ] + ~modules:["Context_ops"] + let _tezos_protocol_shell_context_tests = tests ["test_proxy_context"] @@ -3846,6 +3861,7 @@ include Tezos_raw_protocol_%s.Main tezos_context |> open_; tezos_context_memory |> if_ N.(number >= 012); tezos_rpc_http_client_unix |> if_ N.(number >= 011); + tezos_context_ops |> if_ N.(number >= 011) |> open_; tezos_rpc |> open_; tezos_rpc_http |> open_; lwt_canceler; diff --git a/opam/tezos-baking-012-Psithaca.opam b/opam/tezos-baking-012-Psithaca.opam index c1f456994970..282d3fde536c 100644 --- a/opam/tezos-baking-012-Psithaca.opam +++ b/opam/tezos-baking-012-Psithaca.opam @@ -23,6 +23,7 @@ depends: [ "tezos-shell-context" "tezos-context" "tezos-rpc-http-client-unix" + "tezos-context-ops" "tezos-rpc" "tezos-rpc-http" "lwt-canceler" { >= "0.3" & < "0.4" } diff --git a/opam/tezos-baking-013-PtJakart.opam b/opam/tezos-baking-013-PtJakart.opam index 40f9304bae83..151daf37feba 100644 --- a/opam/tezos-baking-013-PtJakart.opam +++ b/opam/tezos-baking-013-PtJakart.opam @@ -23,6 +23,7 @@ depends: [ "tezos-shell-context" "tezos-context" "tezos-rpc-http-client-unix" + "tezos-context-ops" "tezos-rpc" "tezos-rpc-http" "lwt-canceler" { >= "0.3" & < "0.4" } diff --git a/opam/tezos-baking-alpha.opam b/opam/tezos-baking-alpha.opam index 49bf385dcfe0..be559da7e221 100644 --- a/opam/tezos-baking-alpha.opam +++ b/opam/tezos-baking-alpha.opam @@ -23,6 +23,7 @@ depends: [ "tezos-shell-context" "tezos-context" "tezos-rpc-http-client-unix" + "tezos-context-ops" "tezos-rpc" "tezos-rpc-http" "lwt-canceler" { >= "0.3" & < "0.4" } diff --git a/opam/tezos-context-ops.opam b/opam/tezos-context-ops.opam new file mode 100644 index 000000000000..b9e7b402a3a9 --- /dev/null +++ b/opam/tezos-context-ops.opam @@ -0,0 +1,23 @@ +# This file was automatically generated, do not edit. +# Edit file manifest/main.ml instead. +opam-version: "2.0" +maintainer: "contact@tezos.com" +authors: ["Tezos devteam"] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "git+https://gitlab.com/tezos/tezos.git" +license: "MIT" +depends: [ + "dune" { >= "3.0" } + "tezos-base" + "tezos-error-monad" + "tezos-protocol-environment" + "tezos-context" + "tezos-shell-context" +] +build: [ + ["rm" "-r" "vendors"] + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +synopsis: "Tezos: backend-agnostic operations on constexts" diff --git a/src/proto_012_Psithaca/lib_delegate/context_ops.ml b/src/lib_protocol_environment/context_ops.ml similarity index 84% rename from src/proto_012_Psithaca/lib_delegate/context_ops.ml rename to src/lib_protocol_environment/context_ops.ml index 8762bc9ddd3b..ea01f6cbed4b 100644 --- a/src/proto_012_Psithaca/lib_delegate/context_ops.ml +++ b/src/lib_protocol_environment/context_ops.ml @@ -47,13 +47,18 @@ let get_protocol (context : Environment_context.Context.t) = let add_predecessor_block_metadata_hash (context : Environment_context.Context.t) hash = + let open Lwt_syntax in match context with | Context {kind = Shell_context.Context; ctxt; _} -> - Context.add_predecessor_block_metadata_hash ctxt hash - >|= Shell_context.wrap_disk_context + let+ ctxt = Context.add_predecessor_block_metadata_hash ctxt hash in + Shell_context.wrap_disk_context ctxt | Context {kind = Memory_context.Context; ctxt; _} -> - Tezos_context_memory.Context.add_predecessor_block_metadata_hash ctxt hash - >|= Memory_context.wrap_memory_context + let+ ctxt = + Tezos_context_memory.Context.add_predecessor_block_metadata_hash + ctxt + hash + in + Memory_context.wrap_memory_context ctxt | Context t -> Environment_context.err_implementation_mismatch ~expected:"shell or memory" @@ -61,13 +66,16 @@ let add_predecessor_block_metadata_hash let add_predecessor_ops_metadata_hash (context : Environment_context.Context.t) hash = + let open Lwt_syntax in match context with | Context {kind = Shell_context.Context; ctxt; _} -> - Context.add_predecessor_ops_metadata_hash ctxt hash - >|= Shell_context.wrap_disk_context + let+ ctxt = Context.add_predecessor_ops_metadata_hash ctxt hash in + Shell_context.wrap_disk_context ctxt | Context {kind = Memory_context.Context; ctxt; _} -> - Tezos_context_memory.Context.add_predecessor_ops_metadata_hash ctxt hash - >|= Memory_context.wrap_memory_context + let+ ctxt = + Tezos_context_memory.Context.add_predecessor_ops_metadata_hash ctxt hash + in + Memory_context.wrap_memory_context ctxt | Context t -> Environment_context.err_implementation_mismatch ~expected:"shell or memory" @@ -96,12 +104,14 @@ let get_test_chain (context : Environment_context.Context.t) = ~got:t.impl_name let add_test_chain (context : Environment_context.Context.t) status = + let open Lwt_syntax in match context with | Context {kind = Shell_context.Context; ctxt; _} -> - Context.add_test_chain ctxt status >|= Shell_context.wrap_disk_context + let+ ctxt = Context.add_test_chain ctxt status in + Shell_context.wrap_disk_context ctxt | Context {kind = Memory_context.Context; ctxt; _} -> - Tezos_context_memory.Context.add_test_chain ctxt status - >|= Memory_context.wrap_memory_context + let+ ctxt = Tezos_context_memory.Context.add_test_chain ctxt status in + Memory_context.wrap_memory_context ctxt | Context t -> Environment_context.err_implementation_mismatch ~expected:"shell or memory" diff --git a/src/lib_protocol_environment/dune b/src/lib_protocol_environment/dune index 646c62697020..ce5da4e3d9c5 100644 --- a/src/lib_protocol_environment/dune +++ b/src/lib_protocol_environment/dune @@ -56,3 +56,21 @@ (flags (:standard) -open Tezos_base.TzPervasives) (modules Proxy_delegate_maker Shell_context)) + +(library + (name tezos_context_ops) + (public_name tezos-context-ops) + (instrumentation (backend bisect_ppx)) + (libraries + tezos-base + tezos-error-monad + tezos-protocol-environment + tezos-context + tezos-shell-context) + (flags + (:standard) + -open Tezos_base.TzPervasives + -open Tezos_error_monad + -open Tezos_context + -open Tezos_shell_context) + (modules Context_ops)) diff --git a/src/proto_012_Psithaca/lib_delegate/dune b/src/proto_012_Psithaca/lib_delegate/dune index d77dc59b050a..2b6b172c335a 100644 --- a/src/proto_012_Psithaca/lib_delegate/dune +++ b/src/proto_012_Psithaca/lib_delegate/dune @@ -21,6 +21,7 @@ tezos-context tezos-context.memory tezos-rpc-http-client-unix + tezos-context-ops tezos-rpc tezos-rpc-http lwt-canceler @@ -40,6 +41,7 @@ -open Tezos_stdlib_unix -open Tezos_shell_context -open Tezos_context + -open Tezos_context_ops -open Tezos_rpc -open Tezos_rpc_http) (modules (:standard \ Baking_commands Baking_commands_registration))) diff --git a/src/proto_013_PtJakart/lib_delegate/context_ops.ml b/src/proto_013_PtJakart/lib_delegate/context_ops.ml deleted file mode 100644 index 8762bc9ddd3b..000000000000 --- a/src/proto_013_PtJakart/lib_delegate/context_ops.ml +++ /dev/null @@ -1,108 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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. *) -(* *) -(*****************************************************************************) - -(* Backend-agnostic operations on the context *) - -let mem (context : Environment_context.Context.t) key = - match context with - | Context {kind = Shell_context.Context; ctxt; _} -> Context.mem ctxt key - | Context {kind = Memory_context.Context; ctxt; _} -> - Tezos_context_memory.Context.mem ctxt key - | Context t -> - Environment_context.err_implementation_mismatch - ~expected:"shell or memory" - ~got:t.impl_name - -let get_protocol (context : Environment_context.Context.t) = - match context with - | Context {kind = Shell_context.Context; ctxt; _} -> Context.get_protocol ctxt - | Context {kind = Memory_context.Context; ctxt; _} -> - Tezos_context_memory.Context.get_protocol ctxt - | Context t -> - Environment_context.err_implementation_mismatch - ~expected:"shell or memory" - ~got:t.impl_name - -let add_predecessor_block_metadata_hash - (context : Environment_context.Context.t) hash = - match context with - | Context {kind = Shell_context.Context; ctxt; _} -> - Context.add_predecessor_block_metadata_hash ctxt hash - >|= Shell_context.wrap_disk_context - | Context {kind = Memory_context.Context; ctxt; _} -> - Tezos_context_memory.Context.add_predecessor_block_metadata_hash ctxt hash - >|= Memory_context.wrap_memory_context - | Context t -> - Environment_context.err_implementation_mismatch - ~expected:"shell or memory" - ~got:t.impl_name - -let add_predecessor_ops_metadata_hash (context : Environment_context.Context.t) - hash = - match context with - | Context {kind = Shell_context.Context; ctxt; _} -> - Context.add_predecessor_ops_metadata_hash ctxt hash - >|= Shell_context.wrap_disk_context - | Context {kind = Memory_context.Context; ctxt; _} -> - Tezos_context_memory.Context.add_predecessor_ops_metadata_hash ctxt hash - >|= Memory_context.wrap_memory_context - | Context t -> - Environment_context.err_implementation_mismatch - ~expected:"shell or memory" - ~got:t.impl_name - -let hash ~time ?message (context : Environment_context.Context.t) = - match context with - | Context {kind = Shell_context.Context; ctxt; _} -> - Context.hash ~time ?message ctxt - | Context {kind = Memory_context.Context; ctxt; _} -> - Tezos_context_memory.Context.hash ~time ?message ctxt - | Context t -> - Environment_context.err_implementation_mismatch - ~expected:"shell or memory" - ~got:t.impl_name - -let get_test_chain (context : Environment_context.Context.t) = - match context with - | Context {kind = Shell_context.Context; ctxt; _} -> - Context.get_test_chain ctxt - | Context {kind = Memory_context.Context; _} -> - Lwt.return Test_chain_status.Not_running - | Context t -> - Environment_context.err_implementation_mismatch - ~expected:"shell or memory" - ~got:t.impl_name - -let add_test_chain (context : Environment_context.Context.t) status = - match context with - | Context {kind = Shell_context.Context; ctxt; _} -> - Context.add_test_chain ctxt status >|= Shell_context.wrap_disk_context - | Context {kind = Memory_context.Context; ctxt; _} -> - Tezos_context_memory.Context.add_test_chain ctxt status - >|= Memory_context.wrap_memory_context - | Context t -> - Environment_context.err_implementation_mismatch - ~expected:"shell or memory" - ~got:t.impl_name diff --git a/src/proto_013_PtJakart/lib_delegate/dune b/src/proto_013_PtJakart/lib_delegate/dune index 1a0694f4d5b2..32be22c5bcd4 100644 --- a/src/proto_013_PtJakart/lib_delegate/dune +++ b/src/proto_013_PtJakart/lib_delegate/dune @@ -21,6 +21,7 @@ tezos-context tezos-context.memory tezos-rpc-http-client-unix + tezos-context-ops tezos-rpc tezos-rpc-http lwt-canceler @@ -40,6 +41,7 @@ -open Tezos_stdlib_unix -open Tezos_shell_context -open Tezos_context + -open Tezos_context_ops -open Tezos_rpc -open Tezos_rpc_http) (modules (:standard \ Baking_commands Baking_commands_registration))) diff --git a/src/proto_alpha/lib_delegate/context_ops.ml b/src/proto_alpha/lib_delegate/context_ops.ml deleted file mode 100644 index 8762bc9ddd3b..000000000000 --- a/src/proto_alpha/lib_delegate/context_ops.ml +++ /dev/null @@ -1,108 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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. *) -(* *) -(*****************************************************************************) - -(* Backend-agnostic operations on the context *) - -let mem (context : Environment_context.Context.t) key = - match context with - | Context {kind = Shell_context.Context; ctxt; _} -> Context.mem ctxt key - | Context {kind = Memory_context.Context; ctxt; _} -> - Tezos_context_memory.Context.mem ctxt key - | Context t -> - Environment_context.err_implementation_mismatch - ~expected:"shell or memory" - ~got:t.impl_name - -let get_protocol (context : Environment_context.Context.t) = - match context with - | Context {kind = Shell_context.Context; ctxt; _} -> Context.get_protocol ctxt - | Context {kind = Memory_context.Context; ctxt; _} -> - Tezos_context_memory.Context.get_protocol ctxt - | Context t -> - Environment_context.err_implementation_mismatch - ~expected:"shell or memory" - ~got:t.impl_name - -let add_predecessor_block_metadata_hash - (context : Environment_context.Context.t) hash = - match context with - | Context {kind = Shell_context.Context; ctxt; _} -> - Context.add_predecessor_block_metadata_hash ctxt hash - >|= Shell_context.wrap_disk_context - | Context {kind = Memory_context.Context; ctxt; _} -> - Tezos_context_memory.Context.add_predecessor_block_metadata_hash ctxt hash - >|= Memory_context.wrap_memory_context - | Context t -> - Environment_context.err_implementation_mismatch - ~expected:"shell or memory" - ~got:t.impl_name - -let add_predecessor_ops_metadata_hash (context : Environment_context.Context.t) - hash = - match context with - | Context {kind = Shell_context.Context; ctxt; _} -> - Context.add_predecessor_ops_metadata_hash ctxt hash - >|= Shell_context.wrap_disk_context - | Context {kind = Memory_context.Context; ctxt; _} -> - Tezos_context_memory.Context.add_predecessor_ops_metadata_hash ctxt hash - >|= Memory_context.wrap_memory_context - | Context t -> - Environment_context.err_implementation_mismatch - ~expected:"shell or memory" - ~got:t.impl_name - -let hash ~time ?message (context : Environment_context.Context.t) = - match context with - | Context {kind = Shell_context.Context; ctxt; _} -> - Context.hash ~time ?message ctxt - | Context {kind = Memory_context.Context; ctxt; _} -> - Tezos_context_memory.Context.hash ~time ?message ctxt - | Context t -> - Environment_context.err_implementation_mismatch - ~expected:"shell or memory" - ~got:t.impl_name - -let get_test_chain (context : Environment_context.Context.t) = - match context with - | Context {kind = Shell_context.Context; ctxt; _} -> - Context.get_test_chain ctxt - | Context {kind = Memory_context.Context; _} -> - Lwt.return Test_chain_status.Not_running - | Context t -> - Environment_context.err_implementation_mismatch - ~expected:"shell or memory" - ~got:t.impl_name - -let add_test_chain (context : Environment_context.Context.t) status = - match context with - | Context {kind = Shell_context.Context; ctxt; _} -> - Context.add_test_chain ctxt status >|= Shell_context.wrap_disk_context - | Context {kind = Memory_context.Context; ctxt; _} -> - Tezos_context_memory.Context.add_test_chain ctxt status - >|= Memory_context.wrap_memory_context - | Context t -> - Environment_context.err_implementation_mismatch - ~expected:"shell or memory" - ~got:t.impl_name diff --git a/src/proto_alpha/lib_delegate/dune b/src/proto_alpha/lib_delegate/dune index 7aff5c7e26e7..454cc8a2529f 100644 --- a/src/proto_alpha/lib_delegate/dune +++ b/src/proto_alpha/lib_delegate/dune @@ -21,6 +21,7 @@ tezos-context tezos-context.memory tezos-rpc-http-client-unix + tezos-context-ops tezos-rpc tezos-rpc-http lwt-canceler @@ -40,6 +41,7 @@ -open Tezos_stdlib_unix -open Tezos_shell_context -open Tezos_context + -open Tezos_context_ops -open Tezos_rpc -open Tezos_rpc_http) (modules (:standard \ Baking_commands Baking_commands_registration))) -- GitLab From 4f6f0c623d9e8a17619bd02ff7cb966e641057eb Mon Sep 17 00:00:00 2001 From: Ilias Garnier Date: Thu, 5 May 2022 10:26:46 +0200 Subject: [PATCH 06/11] lib_proto_env: add operations to context_ops --- src/lib_protocol_environment/context_ops.ml | 25 +++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/src/lib_protocol_environment/context_ops.ml b/src/lib_protocol_environment/context_ops.ml index ea01f6cbed4b..91bd3b46ae45 100644 --- a/src/lib_protocol_environment/context_ops.ml +++ b/src/lib_protocol_environment/context_ops.ml @@ -35,6 +35,20 @@ let mem (context : Environment_context.Context.t) key = ~expected:"shell or memory" ~got:t.impl_name +let add_protocol (context : Environment_context.Context.t) proto_hash = + let open Lwt_syntax in + match context with + | Context {kind = Shell_context.Context; ctxt; _} -> + let+ ctxt = Context.add_protocol ctxt proto_hash in + Shell_context.wrap_disk_context ctxt + | Context {kind = Memory_context.Context; ctxt; _} -> + let+ ctxt = Tezos_context_memory.Context.add_protocol ctxt proto_hash in + Memory_context.wrap_memory_context ctxt + | Context t -> + Environment_context.err_implementation_mismatch + ~expected:"shell or memory" + ~got:t.impl_name + let get_protocol (context : Environment_context.Context.t) = match context with | Context {kind = Shell_context.Context; ctxt; _} -> Context.get_protocol ctxt @@ -116,3 +130,14 @@ let add_test_chain (context : Environment_context.Context.t) status = Environment_context.err_implementation_mismatch ~expected:"shell or memory" ~got:t.impl_name + +let commit ~time ?message (context : Environment_context.Context.t) = + match context with + | Context {kind = Shell_context.Context; ctxt; _} -> + Context.commit ~time ?message ctxt + | Context {kind = Memory_context.Context; ctxt; _} -> + Tezos_context_memory.Context.commit ~time ?message ctxt + | Context t -> + Environment_context.err_implementation_mismatch + ~expected:"shell or memory" + ~got:t.impl_name -- GitLab From ae37624d2c3360655941285f2cc9248074d5e0d3 Mon Sep 17 00:00:00 2001 From: Ilias Garnier Date: Thu, 5 May 2022 10:49:00 +0200 Subject: [PATCH 07/11] lib_validation: work on Environment_context.Context.t only --- manifest/main.ml | 2 +- opam/tezos-validation.opam | 2 +- src/lib_protocol_environment/context_ops.ml | 24 +++++++ src/lib_validation/block_validation.ml | 78 ++++++++++----------- src/lib_validation/block_validation.mli | 21 +++--- src/lib_validation/dune | 4 +- 6 files changed, 79 insertions(+), 52 deletions(-) diff --git a/manifest/main.ml b/manifest/main.ml index 654265a2ece4..00abcdf1784e 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -1957,7 +1957,7 @@ let tezos_validation = [ tezos_base |> open_ ~m:"TzPervasives"; tezos_context |> open_; - tezos_shell_context |> open_; + tezos_context_ops |> open_; tezos_shell_services |> open_; tezos_protocol_updater |> open_; tezos_stdlib_unix |> open_; diff --git a/opam/tezos-validation.opam b/opam/tezos-validation.opam index c3e6c9aed1f8..e855272c29e4 100644 --- a/opam/tezos-validation.opam +++ b/opam/tezos-validation.opam @@ -11,7 +11,7 @@ depends: [ "dune" { >= "3.0" } "tezos-base" "tezos-context" - "tezos-shell-context" + "tezos-context-ops" "tezos-shell-services" "tezos-protocol-updater" "tezos-stdlib-unix" diff --git a/src/lib_protocol_environment/context_ops.ml b/src/lib_protocol_environment/context_ops.ml index 91bd3b46ae45..a65d2064a920 100644 --- a/src/lib_protocol_environment/context_ops.ml +++ b/src/lib_protocol_environment/context_ops.ml @@ -141,3 +141,27 @@ let commit ~time ?message (context : Environment_context.Context.t) = Environment_context.err_implementation_mismatch ~expected:"shell or memory" ~got:t.impl_name + +let commit_test_chain_genesis (context : Environment_context.Context.t) + block_header = + match context with + | Context {kind = Shell_context.Context; ctxt; _} -> + Context.commit_test_chain_genesis ctxt block_header + | Context {kind = Memory_context.Context; ctxt; _} -> + Tezos_context_memory.Context.commit_test_chain_genesis ctxt block_header + | Context t -> + Environment_context.err_implementation_mismatch + ~expected:"shell or memory" + ~got:t.impl_name + +let compute_testchain_genesis (context : Environment_context.Context.t) + block_hash = + match context with + | Context {kind = Shell_context.Context; _} -> + Context.compute_testchain_genesis block_hash + | Context {kind = Memory_context.Context; _} -> + Tezos_context_memory.Context.compute_testchain_genesis block_hash + | Context t -> + Environment_context.err_implementation_mismatch + ~expected:"shell or memory" + ~got:t.impl_name diff --git a/src/lib_validation/block_validation.ml b/src/lib_validation/block_validation.ml index a95a6153b1c5..f14067c4edbe 100644 --- a/src/lib_validation/block_validation.ml +++ b/src/lib_validation/block_validation.ml @@ -139,24 +139,26 @@ let check_proto_environment_version_increasing block_hash before after = let update_testchain_status ctxt ~predecessor_hash timestamp = let open Lwt_syntax in - let* tc = Context.get_test_chain ctxt in + let* tc = Context_ops.get_test_chain ctxt in match tc with | Not_running -> Lwt.return ctxt | Running {expiration; _} -> if Time.Protocol.(expiration <= timestamp) then - Context.add_test_chain ctxt Not_running + Context_ops.add_test_chain ctxt Not_running else Lwt.return ctxt | Forking {protocol; expiration} -> - let genesis = Context.compute_testchain_genesis predecessor_hash in + let genesis = + Context_ops.compute_testchain_genesis ctxt predecessor_hash + in let chain_id = Chain_id.of_block_hash genesis in (* legacy semantics *) - Context.add_test_chain + Context_ops.add_test_chain ctxt (Running {chain_id; genesis; protocol; expiration}) let init_test_chain chain_id ctxt forked_header = let open Lwt_result_syntax in - let*! tc = Context.get_test_chain ctxt in + let*! tc = Context_ops.get_test_chain ctxt in match tc with | Not_running | Running _ -> assert false | Forking {protocol; _} -> @@ -165,7 +167,7 @@ let init_test_chain chain_id ctxt forked_header = | Some proto -> return proto | None -> tzfail (Missing_test_protocol protocol) in - let test_ctxt = Shell_context.wrap_disk_context ctxt in + let test_ctxt = ctxt in let*! () = Validation_events.(emit new_protocol_initialisation protocol) in @@ -174,10 +176,10 @@ let init_test_chain chain_id ctxt forked_header = let* {context = test_ctxt; _} = Proto_test.init chain_id test_ctxt forked_header.Block_header.shell in - let test_ctxt = Shell_context.unwrap_disk_context test_ctxt in - let*! test_ctxt = Context.add_test_chain test_ctxt Not_running in - let*! test_ctxt = Context.add_protocol test_ctxt protocol in - Lwt_result.ok @@ Context.commit_test_chain_genesis test_ctxt forked_header + let*! test_ctxt = Context_ops.add_test_chain test_ctxt Not_running in + let*! test_ctxt = Context_ops.add_protocol test_ctxt protocol in + Lwt_result.ok + @@ Context_ops.commit_test_chain_genesis test_ctxt forked_header let result_encoding = let open Data_encoding in @@ -243,8 +245,8 @@ let may_patch_protocol ~user_activated_upgrades ~user_activated_protocol_overrides ~level (validation_result : Tezos_protocol_environment.validation_result) = let open Lwt_syntax in - let context = Shell_context.unwrap_disk_context validation_result.context in - let* protocol = Context.get_protocol context in + let context = validation_result.context in + let* protocol = Context_ops.get_protocol context in match Block_header.get_voted_protocol_overrides ~user_activated_protocol_overrides @@ -495,14 +497,15 @@ module Make (Proto : Registered_protocol.T) = struct let*! context = match predecessor_block_metadata_hash with | None -> Lwt.return context - | Some hash -> Context.add_predecessor_block_metadata_hash context hash + | Some hash -> + Context_ops.add_predecessor_block_metadata_hash context hash in let*! context = match predecessor_ops_metadata_hash with | None -> Lwt.return context - | Some hash -> Context.add_predecessor_ops_metadata_hash context hash + | Some hash -> Context_ops.add_predecessor_ops_metadata_hash context hash in - return @@ Shell_context.wrap_disk_context context + return context (* FIXME: This code is used by recompute_metadata but emitting time measurement events in proto_apply_operations should not impact @@ -591,7 +594,7 @@ module Make (Proto : Registered_protocol.T) = struct block_header.shell.timestamp -> let*! () = Validation_events.(emit using_preapply_result block_hash) in let*! context_hash = - Context.commit + Context_ops.commit ~time:block_header.shell.timestamp ?message:result.validation_store.message context @@ -636,10 +639,8 @@ module Make (Proto : Registered_protocol.T) = struct ~level:block_header.shell.level validation_result in - let context = - Shell_context.unwrap_disk_context validation_result.context - in - let*! new_protocol = Context.get_protocol context in + let context = validation_result.context in + let*! new_protocol = Context_ops.get_protocol context in let expected_proto_level = if Protocol_hash.equal new_protocol Proto.hash then predecessor_block_header.shell.proto_level @@ -689,11 +690,9 @@ module Make (Proto : Registered_protocol.T) = struct ops_metadata in let (Context {cache; _}) = validation_result.context in - let context = - Shell_context.unwrap_disk_context validation_result.context - in + let context = validation_result.context in let*! context_hash = - (Context.commit + (Context_ops.commit ~time:block_header.shell.timestamp ?message:validation_result.message context [@time.duration_lwt context_commitment] [@time.flush]) @@ -745,8 +744,8 @@ module Make (Proto : Registered_protocol.T) = struct block_hash operations in - let context = Shell_context.unwrap_disk_context validation_result.context in - let*! new_protocol = Context.get_protocol context in + let context = validation_result.context in + let*! new_protocol = Context_ops.get_protocol context in let* _validation_result, new_protocol_env_version = may_init_new_protocol chain_id @@ -852,7 +851,7 @@ module Make (Proto : Registered_protocol.T) = struct else return context | Some hash -> Lwt_result.ok - @@ Context.add_predecessor_block_metadata_hash context hash + @@ Context_ops.add_predecessor_block_metadata_hash context hash in let* context = match predecessor_ops_metadata_hash with @@ -862,13 +861,12 @@ module Make (Proto : Registered_protocol.T) = struct else return context | Some hash -> Lwt_result.ok - @@ Context.add_predecessor_ops_metadata_hash context hash + @@ Context_ops.add_predecessor_ops_metadata_hash context hash in - let wrapped_context = Shell_context.wrap_disk_context context in let* state = Proto.begin_construction ~chain_id - ~predecessor_context:wrapped_context + ~predecessor_context:context ~predecessor_timestamp:predecessor_shell_header.Block_header.timestamp ~predecessor_fitness:predecessor_shell_header.Block_header.fitness ~predecessor_level:predecessor_shell_header.level @@ -1028,9 +1026,12 @@ module Make (Proto : Registered_protocol.T) = struct in return (validation_result, cache, NewProto.environment_version) in - let context = Shell_context.unwrap_disk_context validation_result.context in + let context = validation_result.context in let context_hash = - Context.hash ?message:validation_result.message ~time:timestamp context + Context_ops.hash + ?message:validation_result.message + ~time:timestamp + context in let preapply_result = ({shell_header with context = context_hash}, validation_result_list) @@ -1080,7 +1081,6 @@ module Make (Proto : Registered_protocol.T) = struct block_header.shell.timestamp in let* operations = parse_operations block_hash operations in - let context = Shell_context.wrap_disk_context context in let* state = Proto.begin_partial_application ~chain_id @@ -1169,7 +1169,7 @@ type apply_environment = { max_operations_ttl : int; chain_id : Chain_id.t; predecessor_block_header : Block_header.t; - predecessor_context : Context.t; + predecessor_context : Environment_context.Context.t; predecessor_block_metadata_hash : Block_metadata_hash.t option; predecessor_ops_metadata_hash : Operation_metadata_list_list_hash.t option; user_activated_upgrades : User_activated.upgrades; @@ -1181,7 +1181,7 @@ let recompute_metadata chain_id ~predecessor_block_header ~predecessor_context ~predecessor_block_metadata_hash ~predecessor_ops_metadata_hash ~cache block_hash block_header operations = let open Lwt_result_syntax in - let*! pred_protocol_hash = Context.get_protocol predecessor_context in + let*! pred_protocol_hash = Context_ops.get_protocol predecessor_context in let* (module Proto) = match Registered_protocol.get pred_protocol_hash with | None -> @@ -1236,7 +1236,7 @@ let apply ?cached_result predecessor_context; } ~cache block_hash block_header operations = let open Lwt_result_syntax in - let*! pred_protocol_hash = Context.get_protocol predecessor_context in + let*! pred_protocol_hash = Context_ops.get_protocol predecessor_context in let* (module Proto) = match Registered_protocol.get pred_protocol_hash with | None -> @@ -1272,7 +1272,7 @@ let apply ?cached_result c ~cache block_header operations = in match r with | Error (Validation_errors.Inconsistent_hash _ :: _) -> - let*! protocol_hash = Context.get_protocol c.predecessor_context in + let*! protocol_hash = Context_ops.get_protocol c.predecessor_context in let hangzhou_hash = Protocol_hash.of_b58check_exn "PtHangz2aRngywmSRGGvrcTyMbbdpWdpFKuS4uMWxg2RaH9i1qx" @@ -1302,7 +1302,7 @@ let precheck ~chain_id ~predecessor_block_header ~predecessor_block_hash ~predecessor_context ~cache block_header operations = let open Lwt_result_syntax in let block_hash = Block_header.hash block_header in - let*! pred_protocol_hash = Context.get_protocol predecessor_context in + let*! pred_protocol_hash = Context_ops.get_protocol predecessor_context in let* (module Proto) = match Registered_protocol.get pred_protocol_hash with | None -> @@ -1327,7 +1327,7 @@ let preapply ~chain_id ~user_activated_upgrades ~predecessor_shell_header ~predecessor_hash ~predecessor_max_operations_ttl ~predecessor_block_metadata_hash ~predecessor_ops_metadata_hash operations = let open Lwt_result_syntax in - let*! protocol = Context.get_protocol predecessor_context in + let*! protocol = Context_ops.get_protocol predecessor_context in let* (module Proto) = match Registered_protocol.get protocol with | None -> diff --git a/src/lib_validation/block_validation.mli b/src/lib_validation/block_validation.mli index 9d29f56ee094..7197fa6f998d 100644 --- a/src/lib_validation/block_validation.mli +++ b/src/lib_validation/block_validation.mli @@ -46,10 +46,10 @@ val may_patch_protocol : Tezos_protocol_environment.validation_result Lwt.t val update_testchain_status : - Context.t -> + Environment_context.Context.t -> predecessor_hash:Block_hash.t -> Time.Protocol.t -> - Context.t Lwt.t + Environment_context.Context.t Lwt.t (** [check_proto_environment_version_increasing hash before after] returns successfully if the environment version stays the same or @@ -60,7 +60,10 @@ val check_proto_environment_version_increasing : (** [init_test_chain] must only be called on a forking block. *) val init_test_chain : - Chain_id.t -> Context.t -> Block_header.t -> Block_header.t tzresult Lwt.t + Chain_id.t -> + Environment_context.Context.t -> + Block_header.t -> + Block_header.t tzresult Lwt.t type operation_metadata = Metadata of Bytes.t | Too_large_metadata @@ -97,7 +100,7 @@ type apply_environment = { chain_id : Chain_id.t; (** chain_id of the current branch *) predecessor_block_header : Block_header.t; (** header of the predecessor block being validated *) - predecessor_context : Context.t; + predecessor_context : Environment_context.Context.t; (** context associated to the predecessor block *) predecessor_block_metadata_hash : Block_metadata_hash.t option; (** hash of block header metadata of the predecessor block *) @@ -121,7 +124,7 @@ val default_operation_metadata_size_limit : int option 3. [P.finalize_block] *) val apply : - ?cached_result:apply_result * Context.t -> + ?cached_result:apply_result * Environment_context.Context.t -> apply_environment -> cache:Environment_context.Context.source_of_cache -> Block_header.t -> @@ -137,7 +140,7 @@ val precheck : chain_id:Chain_id.t -> predecessor_block_header:Block_header.t -> predecessor_block_hash:Block_hash.t -> - predecessor_context:Context.t -> + predecessor_context:Environment_context.Context.t -> cache:Environment_context.Context.source_of_cache -> Block_header.t -> Operation.t list list -> @@ -152,7 +155,7 @@ val preapply : protocol_data:bytes -> live_blocks:Block_hash.Set.t -> live_operations:Operation_hash.Set.t -> - predecessor_context:Context.t -> + predecessor_context:Environment_context.Context.t -> predecessor_shell_header:Block_header.shell_header -> predecessor_hash:Block_hash.t -> predecessor_max_operations_ttl:int -> @@ -160,14 +163,14 @@ val preapply : predecessor_ops_metadata_hash:Operation_metadata_list_list_hash.t option -> Operation.t list list -> ((Block_header.shell_header * error Preapply_result.t list) - * (apply_result * Context.t)) + * (apply_result * Environment_context.Context.t)) tzresult Lwt.t val recompute_metadata : chain_id:Chain_id.t -> predecessor_block_header:Block_header.t -> - predecessor_context:Context.t -> + predecessor_context:Environment_context.Context.t -> predecessor_block_metadata_hash:Block_metadata_hash.t option -> predecessor_ops_metadata_hash:Operation_metadata_list_list_hash.t option -> block_header:Block_header.t -> diff --git a/src/lib_validation/dune b/src/lib_validation/dune index d2a5295031ce..33fae9bb2482 100644 --- a/src/lib_validation/dune +++ b/src/lib_validation/dune @@ -9,7 +9,7 @@ (libraries tezos-base tezos-context - tezos-shell-context + tezos-context-ops tezos-shell-services tezos-protocol-updater tezos-stdlib-unix) @@ -17,7 +17,7 @@ (:standard) -open Tezos_base.TzPervasives -open Tezos_context - -open Tezos_shell_context + -open Tezos_context_ops -open Tezos_shell_services -open Tezos_protocol_updater -open Tezos_stdlib_unix)) -- GitLab From 575ad98ec85a400fecd3ecc9e8e9341e59fe3f65 Mon Sep 17 00:00:00 2001 From: Ilias Garnier Date: Thu, 5 May 2022 11:14:53 +0200 Subject: [PATCH 08/11] lib_shell,lib_store,bin_validation: propagate use of abstract ctxt --- manifest/main.ml | 2 ++ opam/tezos-store.opam | 1 + opam/tezos-validator.opam | 1 + src/bin_validation/dune | 2 ++ src/bin_validation/validator.ml | 13 ++++++++----- src/lib_shell/block_directory.ml | 4 +++- src/lib_shell/block_validator_process.ml | 10 ++++++---- src/lib_shell/prevalidation.ml | 6 +++--- src/lib_store/dune | 1 + src/lib_store/reconstruction.ml | 3 +++ src/lib_store/snapshots.ml | 3 +++ 11 files changed, 33 insertions(+), 13 deletions(-) diff --git a/manifest/main.ml b/manifest/main.ml index 00abcdf1784e..f2d3d728ce94 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -1976,6 +1976,7 @@ let tezos_store = index; irmin_pack; tezos_context |> open_; + tezos_shell_context; tezos_validation |> open_; tezos_protocol_updater |> open_; tezos_stdlib_unix |> open_; @@ -2149,6 +2150,7 @@ let tezos_validator_lib = tezos_base |> open_ ~m:"TzPervasives"; tezos_base_unix; tezos_context |> open_; + tezos_context_ops |> open_; tezos_stdlib_unix |> open_; tezos_protocol_environment; tezos_shell |> open_; diff --git a/opam/tezos-store.opam b/opam/tezos-store.opam index c9ff35350469..51f8e4493f8a 100644 --- a/opam/tezos-store.opam +++ b/opam/tezos-store.opam @@ -15,6 +15,7 @@ depends: [ "index" { >= "1.6.0" & < "1.7.0" } "irmin-pack" { >= "3.2.2" & < "3.3.0" } "tezos-context" + "tezos-shell-context" "tezos-validation" "tezos-protocol-updater" "tezos-stdlib-unix" diff --git a/opam/tezos-validator.opam b/opam/tezos-validator.opam index 7510548677e6..9ade7b5276bb 100644 --- a/opam/tezos-validator.opam +++ b/opam/tezos-validator.opam @@ -11,6 +11,7 @@ depends: [ "dune" { >= "3.0" } "tezos-base" "tezos-context" + "tezos-context-ops" "tezos-stdlib-unix" "tezos-protocol-environment" "tezos-shell" diff --git a/src/bin_validation/dune b/src/bin_validation/dune index 4d9caf473f28..63b88d450bd4 100644 --- a/src/bin_validation/dune +++ b/src/bin_validation/dune @@ -9,6 +9,7 @@ tezos-base tezos-base.unix tezos-context + tezos-context-ops tezos-stdlib-unix tezos-protocol-environment tezos-shell @@ -20,6 +21,7 @@ (:standard) -open Tezos_base.TzPervasives -open Tezos_context + -open Tezos_context_ops -open Tezos_stdlib_unix -open Tezos_shell -open Tezos_shell_services diff --git a/src/bin_validation/validator.ml b/src/bin_validation/validator.ml index 3c111802d6fd..e924464ed10a 100644 --- a/src/bin_validation/validator.ml +++ b/src/bin_validation/validator.ml @@ -253,13 +253,13 @@ let run input output = in let*! o = Context.checkout context_index pred_context_hash in match o with - | Some context -> return context + | Some c -> return (Shell_context.wrap_disk_context c) | None -> tzfail (Block_validator_errors.Failed_to_checkout_context pred_context_hash)) in - let*! protocol_hash = Context.get_protocol predecessor_context in + let*! protocol_hash = Context_ops.get_protocol predecessor_context in let* () = load_protocol protocol_hash protocol_root in let env = { @@ -331,13 +331,14 @@ let run input output = Context.checkout context_index pred_context_hash in match context with - | Some context -> return context + | Some context -> + return (Shell_context.wrap_disk_context context) | None -> tzfail (Block_validator_errors.Failed_to_checkout_context pred_context_hash)) in - let*! protocol_hash = Context.get_protocol predecessor_context in + let*! protocol_hash = Context_ops.get_protocol predecessor_context in let* () = load_protocol protocol_hash protocol_root in with_retry_to_load_protocol protocol_root (fun () -> Block_validation.preapply @@ -398,7 +399,8 @@ let run input output = predecessor_block_header.shell.context in match o with - | Some context -> return context + | Some context -> + return (Shell_context.wrap_disk_context context) | None -> tzfail (Block_validator_errors.Failed_to_checkout_context @@ -433,6 +435,7 @@ let run input output = let*! () = match context_opt with | Some ctxt -> + let ctxt = Shell_context.wrap_disk_context ctxt in let*! test_chain_init_result = with_retry_to_load_protocol protocol_root (fun () -> Block_validation.init_test_chain chain_id ctxt forked_header) diff --git a/src/lib_shell/block_directory.ml b/src/lib_shell/block_directory.ml index 64afb1a5d21a..d4695254a330 100644 --- a/src/lib_shell/block_directory.ml +++ b/src/lib_shell/block_directory.ml @@ -288,7 +288,9 @@ let build_raw_rpc_directory (module Proto : Block_services.PROTO) (Context.index context) (Store.Block.context_hash predecessor_block) in - match ctxt with Some c -> return c | None -> fail_with_exn Not_found + match ctxt with + | Some c -> return (Shell_context.wrap_disk_context c) + | None -> fail_with_exn Not_found in let predecessor_block_metadata_hash = Store.Block.block_metadata_hash predecessor_block diff --git a/src/lib_shell/block_validator_process.ml b/src/lib_shell/block_validator_process.ml index a806a24db27d..e6f41333302e 100644 --- a/src/lib_shell/block_validator_process.ml +++ b/src/lib_shell/block_validator_process.ml @@ -153,7 +153,8 @@ module Internal_validator_process = struct of caches passed from one block to the next one here. *) mutable cache : Environment_context.Context.block_cache option; - mutable preapply_result : (Block_validation.apply_result * Context.t) option; + mutable preapply_result : + (Block_validation.apply_result * Environment_context.Context.t) option; } let init @@ -198,7 +199,7 @@ module Internal_validator_process = struct | None -> tzfail (Block_validator_errors.Failed_to_checkout_context context_hash) - | Some ctx -> return ctx + | Some ctx -> return (Shell_context.wrap_disk_context ctx) in let predecessor_block_metadata_hash = Store.Block.block_metadata_hash predecessor @@ -270,7 +271,7 @@ module Internal_validator_process = struct | None -> tzfail (Block_validator_errors.Failed_to_checkout_context context_hash) - | Some ctx -> return ctx + | Some ctx -> return (Shell_context.wrap_disk_context ctx) in let user_activated_upgrades = validator.user_activated_upgrades in let user_activated_protocol_overrides = @@ -315,7 +316,7 @@ module Internal_validator_process = struct | None -> tzfail (Block_validator_errors.Failed_to_checkout_context context_hash) - | Some ctx -> return ctx + | Some ctx -> return (Shell_context.wrap_disk_context ctx) in let cache = match validator.cache with @@ -346,6 +347,7 @@ module Internal_validator_process = struct let open Lwt_result_syntax in let forked_header = Store.Block.header forking_block in let* context = Store.Block.context validator.chain_store forking_block in + let context = Shell_context.wrap_disk_context context in Block_validation.init_test_chain chain_id context forked_header let reconfigure_event_logging _ _ = Lwt_result_syntax.return_unit diff --git a/src/lib_shell/prevalidation.ml b/src/lib_shell/prevalidation.ml index ae446462e809..51a40a58090b 100644 --- a/src/lib_shell/prevalidation.ml +++ b/src/lib_shell/prevalidation.ml @@ -185,6 +185,9 @@ module MakeAbstract Store.Block.header predecessor in let* predecessor_context = Chain_store.context chain_store predecessor in + let predecessor_context = + Shell_context.wrap_disk_context predecessor_context + in let predecessor_hash = Store.Block.hash predecessor in let*! predecessor_context = Block_validation.update_testchain_status @@ -204,9 +207,6 @@ module MakeAbstract | None -> failwith "Invalid block header" | Some protocol_data -> return_some protocol_data) in - let predecessor_context = - Shell_context.wrap_disk_context predecessor_context - in let* state = Proto.begin_construction ~chain_id:(Chain_store.chain_id chain_store) diff --git a/src/lib_store/dune b/src/lib_store/dune index 1bdc8b4bebcf..7b5f5d84e42b 100644 --- a/src/lib_store/dune +++ b/src/lib_store/dune @@ -12,6 +12,7 @@ index irmin-pack tezos-context + tezos-shell-context tezos-validation tezos-protocol-updater tezos-stdlib-unix diff --git a/src/lib_store/reconstruction.ml b/src/lib_store/reconstruction.ml index 59c7939decdd..db9a2ad2b1f7 100644 --- a/src/lib_store/reconstruction.ml +++ b/src/lib_store/reconstruction.ml @@ -208,6 +208,9 @@ let apply_context context_index chain_id ~user_activated_upgrades (Store_errors.Cannot_checkout_context (Store.Block.hash predecessor_block, context_hash)) in + let predecessor_context = + Tezos_shell_context.Shell_context.wrap_disk_context predecessor_context + in let apply_environment = { Block_validation.max_operations_ttl = diff --git a/src/lib_store/snapshots.ml b/src/lib_store/snapshots.ml index f54a3b67d101..ecdc1fdffe7d 100644 --- a/src/lib_store/snapshots.ml +++ b/src/lib_store/snapshots.ml @@ -3540,6 +3540,9 @@ module Make_snapshot_importer (Importer : IMPORTER) : Snapshot_importer = struct | Some ch -> return ch | None -> tzfail (Inconsistent_context pred_context_hash) in + let predecessor_context = + Tezos_shell_context.Shell_context.wrap_disk_context predecessor_context + in let apply_environment = { Block_validation.max_operations_ttl = -- GitLab From da7e0b94f4df500217fc34a83cf902fb1e23d49e Mon Sep 17 00:00:00 2001 From: Ilias Garnier Date: Mon, 9 May 2022 14:45:54 +0200 Subject: [PATCH 09/11] manifest: remove superflous synopsis, fix typo --- manifest/main.ml | 2 +- opam/tezos-context-ops.opam | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/manifest/main.ml b/manifest/main.ml index f2d3d728ce94..e5be53877141 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -1800,7 +1800,7 @@ let tezos_context_ops = public_lib "tezos-context-ops" ~path:"src/lib_protocol_environment" - ~synopsis:"Tezos: backend-agnostic operations on constexts" + ~synopsis:"Tezos: backend-agnostic operations on contexts" ~deps: [ tezos_base |> open_ ~m:"TzPervasives"; diff --git a/opam/tezos-context-ops.opam b/opam/tezos-context-ops.opam index b9e7b402a3a9..a40ff4c75468 100644 --- a/opam/tezos-context-ops.opam +++ b/opam/tezos-context-ops.opam @@ -20,4 +20,4 @@ build: [ ["dune" "build" "-p" name "-j" jobs] ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] -synopsis: "Tezos: backend-agnostic operations on constexts" +synopsis: "Tezos: backend-agnostic operations on contexts" -- GitLab From 282c0d518fd4ba69ca44a0adfeb1a014fcb5059b Mon Sep 17 00:00:00 2001 From: Ilias Garnier Date: Mon, 9 May 2022 18:33:59 +0200 Subject: [PATCH 10/11] lib_context: functorize test_context, run for disk and memory impl --- manifest/main.ml | 4 +- src/lib_context/test/dune | 10 +- src/lib_context/test/test_context.ml | 1398 ++++++++++++++------------ 3 files changed, 777 insertions(+), 635 deletions(-) diff --git a/manifest/main.ml b/manifest/main.ml index e5be53877141..b629879a6113 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -1543,7 +1543,9 @@ let _tezos_context_tests = [ tezos_base |> open_ ~m:"TzPervasives"; tezos_base_unix; - tezos_context_disk |> open_; + tezos_context_sigs; + tezos_context_disk; + tezos_context_memory; tezos_stdlib_unix |> open_; tezos_test_helpers; tezos_test_helpers_extra; diff --git a/src/lib_context/test/dune b/src/lib_context/test/dune index 8888a6016ff7..d33f72a62b85 100644 --- a/src/lib_context/test/dune +++ b/src/lib_context/test/dune @@ -6,16 +6,16 @@ (libraries tezos-base tezos-base.unix + tezos-context.sigs tezos-context.disk + tezos-context.memory tezos-stdlib-unix tezos-test-helpers tezos-test-helpers-extra alcotest-lwt) - (flags - (:standard) - -open Tezos_base.TzPervasives - -open Tezos_context_disk - -open Tezos_stdlib_unix) + (flags (:standard) + -open Tezos_base.TzPervasives + -open Tezos_stdlib_unix) (modules test_context test)) (rule diff --git a/src/lib_context/test/test_context.ml b/src/lib_context/test/test_context.ml index 92beb87756b6..902d0b36f592 100644 --- a/src/lib_context/test/test_context.ml +++ b/src/lib_context/test/test_context.ml @@ -32,7 +32,6 @@ module Assert_lib = Lib_test_extra.Assert_lib module Assert = Lib_test.Assert -open Context let equal_context_hash ?loc ?msg l1 l2 = Assert.equal ?loc ~eq:Context_hash.( = ) ~pp:Context_hash.pp ?msg l1 l2 @@ -66,665 +65,806 @@ let genesis_time = Time.Protocol.of_seconds 0L let chain_id = Chain_id.of_block_hash genesis_block -(** Context creation *) - -let commit = commit ~time:Time.Protocol.epoch ~message:"" - -let create_block2 idx genesis_commit = - let* o = checkout idx genesis_commit in - match o with - | None -> Assert.fail_msg "checkout genesis_block" - | Some ctxt -> - let* ctxt = add ctxt ["a"; "b"] (Bytes.of_string "Novembre") in - let* ctxt = add ctxt ["a"; "c"] (Bytes.of_string "Juin") in - let* ctxt = add ctxt ["version"] (Bytes.of_string "0.0") in - commit ctxt - -let create_block3a idx block2_commit = - let* o = checkout idx block2_commit in - match o with - | None -> Assert.fail_msg "checkout block2" - | Some ctxt -> - let* ctxt = remove ctxt ["a"; "b"] in - let* ctxt = add ctxt ["a"; "d"] (Bytes.of_string "Mars") in - commit ctxt - -let create_block3b idx block2_commit = - let* o = checkout idx block2_commit in - match o with - | None -> Assert.fail_msg "checkout block3b" - | Some ctxt -> - let* ctxt = remove ctxt ["a"; "c"] in - let* ctxt = add ctxt ["a"; "d"] (Bytes.of_string "Février") in - commit ctxt - -type t = { - idx : Context.index; - genesis : Context_hash.t; - block2 : Context_hash.t; - block3a : Context_hash.t; - block3b : Context_hash.t; -} - -type init_config = {indexing_strategy : [`Always | `Minimal]} - -let wrap_context_init config f _ () = - Lwt_utils_unix.with_tempdir "tezos_test_" (fun base_dir -> - let root = base_dir // "context" in - let* idx = - match config with - | None -> Context.init root - | Some {indexing_strategy} -> Context.init ~indexing_strategy root - in - let*!! genesis = - Context.commit_genesis - idx - ~chain_id - ~time:genesis_time - ~protocol:genesis_protocol - in - let* block2 = create_block2 idx genesis in - let* block3a = create_block3a idx block2 in - let* block3b = create_block3b idx block2 in - f {idx; genesis; block2; block3a; block3b}) - -(** Simple test *) - -let c = function None -> None | Some s -> Some (Bytes.to_string s) - -(** Checkout the context applied until [block2]. It is asserted that +(** Test functors *) + +(* Context-generic tests *) +module Make_generic (Tag : sig + val tag : string +end) (Type_parameters : sig + type memory_context_tree +end) +(Context : Tezos_context_sigs.Context.TEZOS_CONTEXT + with type memory_context_tree := + Type_parameters.memory_context_tree) = +struct + open Context + + (** Context creation *) + + let commit = commit ~time:Time.Protocol.epoch ~message:"" + + let create_block2 idx genesis_commit = + let* o = checkout idx genesis_commit in + match o with + | None -> Assert.fail_msg "checkout genesis_block" + | Some ctxt -> + let* ctxt = add ctxt ["a"; "b"] (Bytes.of_string "Novembre") in + let* ctxt = add ctxt ["a"; "c"] (Bytes.of_string "Juin") in + let* ctxt = add ctxt ["version"] (Bytes.of_string "0.0") in + commit ctxt + + let create_block3a idx block2_commit = + let* o = checkout idx block2_commit in + match o with + | None -> Assert.fail_msg "checkout block2" + | Some ctxt -> + let* ctxt = remove ctxt ["a"; "b"] in + let* ctxt = add ctxt ["a"; "d"] (Bytes.of_string "Mars") in + commit ctxt + + let create_block3b idx block2_commit = + let* o = checkout idx block2_commit in + match o with + | None -> Assert.fail_msg "checkout block3b" + | Some ctxt -> + let* ctxt = remove ctxt ["a"; "c"] in + let* ctxt = add ctxt ["a"; "d"] (Bytes.of_string "Février") in + commit ctxt + + type t = { + idx : Context.index; + genesis : Context_hash.t; + block2 : Context_hash.t; + block3a : Context_hash.t; + block3b : Context_hash.t; + } + + type init_config = {indexing_strategy : [`Always | `Minimal]} + + let wrap_context_init config f _ () = + Lwt_utils_unix.with_tempdir "tezos_test_" (fun base_dir -> + let root = base_dir // "context" in + let* idx = + match config with + | None -> Context.init root + | Some {indexing_strategy} -> Context.init ~indexing_strategy root + in + let*!! genesis = + Context.commit_genesis + idx + ~chain_id + ~time:genesis_time + ~protocol:genesis_protocol + in + let* block2 = create_block2 idx genesis in + let* block3a = create_block3a idx block2 in + let* block3b = create_block3b idx block2 in + f {idx; genesis; block2; block3a; block3b}) + + (** Simple test *) + + let c = function None -> None | Some s -> Some (Bytes.to_string s) + + (** Checkout the context applied until [block2]. It is asserted that the following key-values are present: - (["version"], ["0.0"]) - (["a"; "b"], ["Novembre"]) - (["a; "c""], ["Juin"]) *) -let test_simple {idx; block2; _} = - let* o = checkout idx block2 in - match o with - | None -> Assert.fail_msg "checkout block2" - | Some ctxt -> - let* version = find ctxt ["version"] in - Assert.String.Option.equal ~loc:__LOC__ (c version) (Some "0.0") ; - let* novembre = find ctxt ["a"; "b"] in - Assert.String.Option.equal (Some "Novembre") (c novembre) ; - let* juin = find ctxt ["a"; "c"] in - Assert.String.Option.equal ~loc:__LOC__ (Some "Juin") (c juin) ; - Lwt.return_unit - -let test_list {idx; block2; _} = - let* o = checkout idx block2 in - match o with - | None -> Assert.fail_msg "checkout block2" - | Some ctxt -> - let* ls = list ctxt ["a"] in - let ls = List.sort compare (List.map fst ls) in - Assert.String.List.equal ~loc:__LOC__ ["b"; "c"] ls ; - Lwt.return_unit - -(** Checkout the context applied until [block3a]. It is asserted that + let test_simple {idx; block2; _} = + let* o = checkout idx block2 in + match o with + | None -> Assert.fail_msg "checkout block2" + | Some ctxt -> + let* version = find ctxt ["version"] in + Assert.String.Option.equal ~loc:__LOC__ (c version) (Some "0.0") ; + let* novembre = find ctxt ["a"; "b"] in + Assert.String.Option.equal (Some "Novembre") (c novembre) ; + let* juin = find ctxt ["a"; "c"] in + Assert.String.Option.equal ~loc:__LOC__ (Some "Juin") (c juin) ; + Lwt.return_unit + + let test_list {idx; block2; _} = + let* o = checkout idx block2 in + match o with + | None -> Assert.fail_msg "checkout block2" + | Some ctxt -> + let* ls = list ctxt ["a"] in + let ls = List.sort compare (List.map fst ls) in + Assert.String.List.equal ~loc:__LOC__ ["b"; "c"] ls ; + Lwt.return_unit + + (** Checkout the context applied until [block3a]. It is asserted that the following key-values are present: - (["version"], ["0.0"]) - (["a"; "c"], ["Juin"]) - (["a"; "d"], ["Mars"]) Additionally, the key ["a"; "b"] is associated with nothing as it has been removed by block [block3a]. *) -let test_continuation {idx; block3a; _} = - let* o = checkout idx block3a in - match o with - | None -> Assert.fail_msg "checkout block3a" - | Some ctxt -> - let* version = find ctxt ["version"] in - Assert.String.Option.equal ~loc:__LOC__ (Some "0.0") (c version) ; - let* novembre = find ctxt ["a"; "b"] in - Assert.is_none ~loc:__LOC__ (c novembre) ; - let* juin = find ctxt ["a"; "c"] in - Assert.String.Option.equal ~loc:__LOC__ (Some "Juin") (c juin) ; - let* mars = find ctxt ["a"; "d"] in - Assert.String.Option.equal ~loc:__LOC__ (Some "Mars") (c mars) ; - Lwt.return_unit - -(** Checkout the context applied until [block3b]. It is asserted that + let test_continuation {idx; block3a; _} = + let* o = checkout idx block3a in + match o with + | None -> Assert.fail_msg "checkout block3a" + | Some ctxt -> + let* version = find ctxt ["version"] in + Assert.String.Option.equal ~loc:__LOC__ (Some "0.0") (c version) ; + let* novembre = find ctxt ["a"; "b"] in + Assert.is_none ~loc:__LOC__ (c novembre) ; + let* juin = find ctxt ["a"; "c"] in + Assert.String.Option.equal ~loc:__LOC__ (Some "Juin") (c juin) ; + let* mars = find ctxt ["a"; "d"] in + Assert.String.Option.equal ~loc:__LOC__ (Some "Mars") (c mars) ; + Lwt.return_unit + + (** Checkout the context applied until [block3b]. It is asserted that the following key-values are present: - (["version"], ["0.0"]) - (["a"; "b"], ["Novembre"]) - (["a"; "d"], ["Février"]) Additionally, the key ["a"; "c"] is associated with nothing as it has been removed by block [block3b]. *) -let test_fork {idx; block3b; _} = - let* o = checkout idx block3b in - match o with - | None -> Assert.fail_msg "checkout block3b" - | Some ctxt -> - let* version = find ctxt ["version"] in - Assert.String.Option.equal ~loc:__LOC__ (Some "0.0") (c version) ; - let* novembre = find ctxt ["a"; "b"] in - Assert.String.Option.equal ~loc:__LOC__ (Some "Novembre") (c novembre) ; - let* juin = find ctxt ["a"; "c"] in - Assert.is_none ~loc:__LOC__ (c juin) ; - let* mars = find ctxt ["a"; "d"] in - Assert.String.Option.equal ~loc:__LOC__ (Some "Février") (c mars) ; - Lwt.return_unit - -(** Checkout the context at [genesis] and explicitly replay + let test_fork {idx; block3b; _} = + let* o = checkout idx block3b in + match o with + | None -> Assert.fail_msg "checkout block3b" + | Some ctxt -> + let* version = find ctxt ["version"] in + Assert.String.Option.equal ~loc:__LOC__ (Some "0.0") (c version) ; + let* novembre = find ctxt ["a"; "b"] in + Assert.String.Option.equal ~loc:__LOC__ (Some "Novembre") (c novembre) ; + let* juin = find ctxt ["a"; "c"] in + Assert.is_none ~loc:__LOC__ (c juin) ; + let* mars = find ctxt ["a"; "d"] in + Assert.String.Option.equal ~loc:__LOC__ (Some "Février") (c mars) ; + Lwt.return_unit + + (** Checkout the context at [genesis] and explicitly replay setting/getting key-values. *) -let test_replay {idx; genesis; _} = - let* o = checkout idx genesis in - match o with - | None -> Assert.fail_msg "checkout genesis_block" - | Some ctxt0 -> - let* ctxt1 = add ctxt0 ["version"] (Bytes.of_string "0.0") in - let* ctxt2 = add ctxt1 ["a"; "b"] (Bytes.of_string "Novembre") in - let* ctxt3 = add ctxt2 ["a"; "c"] (Bytes.of_string "Juin") in - let* ctxt4a = add ctxt3 ["a"; "d"] (Bytes.of_string "July") in - let* ctxt4b = add ctxt3 ["a"; "d"] (Bytes.of_string "Juillet") in - let* ctxt5a = add ctxt4a ["a"; "b"] (Bytes.of_string "November") in - let* novembre = find ctxt4a ["a"; "b"] in - Assert.String.Option.equal ~loc:__LOC__ (Some "Novembre") (c novembre) ; - let* november = find ctxt5a ["a"; "b"] in - Assert.String.Option.equal ~loc:__LOC__ (Some "November") (c november) ; - let* july = find ctxt5a ["a"; "d"] in - Assert.String.Option.equal ~loc:__LOC__ (Some "July") (c july) ; - let* novembre = find ctxt4b ["a"; "b"] in - Assert.String.Option.equal ~loc:__LOC__ (Some "Novembre") (c novembre) ; - let* juillet = find ctxt4b ["a"; "d"] in - Assert.String.Option.equal ~loc:__LOC__ (Some "Juillet") (c juillet) ; - Lwt.return_unit - -let fold_keys s root ~order ~init ~f = - fold s root ~order ~init ~f:(fun k v acc -> - match Tree.kind v with - | `Value -> f (root @ k) acc - | `Tree -> Lwt.return acc) - -let steps = - ["00"; "01"; "02"; "03"; "05"; "06"; "07"; "09"; "0a"; "0b"; "0c"; - "0e"; "0f"; "10"; "11"; "12"; "13"; "14"; "15"; "16"; "17"; "19"; - "1a"; "1b"; "1c"; "1d"; "1e"; "1f"; "20"; "22"; "23"; "25"; "26"; - "27"; "28"; "2a"; "2b"; "2f"; "30"; "31"; "32"; "33"; "35"; "36"; - "37"; "3a"; "3b"; "3c"; "3d"; "3e"; "3f"; "40"; "42"; "43"; "45"; - "46"; "47"; "48"; "4a"; "4b"; "4c"; "4e"; "4f"; "50"; "52"; "53"; - "54"; "55"; "56"; "57"; "59"; "5b"; "5c"; "5f"; "60"; "61"; "62"; - "63"; "64"; "65"; "66"; "67"; "69"; "6b"; "6c"; "6d"; "6e"; "6f"; - "71"; "72"; "73"; "74"; "75"; "78"; "79"; "7a"; "7b"; "7c"; "7d"; - "7e"; "80"; "82"; "83"; "84"; "85"; "86"; "88"; "8b"; "8c"; "8d"; - "8f"; "92"; "93"; "94"; "96"; "97"; "99"; "9a"; "9b"; "9d"; "9e"; - "9f"; "a0"; "a1"; "a2"; "a3"; "a4"; "a5"; "a6"; "a7"; "a8"; "aa"; - "ab"; "ac"; "ad"; "ae"; "af"; "b0"; "b1"; "b2"; "b3"; "b4"; "b6"; - "b8"; "b9"; "bb"; "bc"; "bf"; "c0"; "c1"; "c2"; "c3"; "c4"; "c5"; - "c8"; "c9"; "cb"; "cc"; "cd"; "ce"; "d0"; "d1"; "d2"; "d4"; "d5"; - "d7"; "d8"; "d9"; "da"; "e0"; "e3"; "e6"; "e8"; "e9"; "ea"; "ec"; - "ee"; "ef"; "f0"; "f1"; "f5"; "f7"; "f8"; "f9"; "fb"; "fc"; "fd"; - "fe"; "ff"] -[@@ocamlformat "disable"] - -let bindings = - let zero = Bytes.make 10 '0' in - List.map (fun x -> (["root"; x], zero)) steps - -let test_fold_keys ~order {idx; genesis; _} = - let keys t = - fold_keys t ~order ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc)) - in - let sort_keys l = - match order with `Sorted -> List.rev l | `Undefined -> List.sort compare l - in - let* o = checkout idx genesis in - match o with - | None -> Assert.fail_msg "checkout genesis_block" - | Some ctxt -> - let* ctxt = add ctxt ["a"; "b"] (Bytes.of_string "Novembre") in - let* ctxt = add ctxt ["a"; "c"] (Bytes.of_string "Juin") in - let* ctxt = add ctxt ["a"; "d"; "e"] (Bytes.of_string "Septembre") in - let* ctxt = add ctxt ["f"] (Bytes.of_string "Avril") in - let* ctxt = add ctxt ["g"; "h"] (Bytes.of_string "Avril") in - let* l = keys ctxt [] in - let l = sort_keys l in - Assert.String.List_list.equal - ~loc:__LOC__ - [["a"; "b"]; ["a"; "c"]; ["a"; "d"; "e"]; ["f"]; ["g"; "h"]] - l ; - let* l = keys ctxt ["a"] in - let l = sort_keys l in - Assert.String.List_list.equal - ~loc:__LOC__ - [["a"; "b"]; ["a"; "c"]; ["a"; "d"; "e"]] - l ; - let* l = keys ctxt ["f"] in - Assert.String.List_list.equal ~loc:__LOC__ [] l ; - let* l = keys ctxt ["g"] in - Assert.String.List_list.equal ~loc:__LOC__ [["g"; "h"]] l ; - let* l = keys ctxt ["i"] in - Assert.String.List_list.equal ~loc:__LOC__ [] l ; - let* ctxt = - Lwt_list.fold_left_s (fun ctxt (k, v) -> add ctxt k v) ctxt bindings - in - let* h = commit ctxt in - let* ctxt = checkout_exn idx h in - let* bs = - fold_keys ctxt ["root"] ~order ~init:[] ~f:(fun k acc -> - Lwt.return (k :: acc)) - in - let bs = sort_keys bs in - Assert.String.List_list.equal ~loc:__LOC__ (List.map fst bindings) bs ; - Lwt.return_unit - -let test_fold_keys_sorted = test_fold_keys ~order:`Sorted - -let test_fold_keys_undefined = test_fold_keys ~order:`Undefined - -(** Checkout the context at [genesis] and fold upon a context a series + let test_replay {idx; genesis; _} = + let* o = checkout idx genesis in + match o with + | None -> Assert.fail_msg "checkout genesis_block" + | Some ctxt0 -> + let* ctxt1 = add ctxt0 ["version"] (Bytes.of_string "0.0") in + let* ctxt2 = add ctxt1 ["a"; "b"] (Bytes.of_string "Novembre") in + let* ctxt3 = add ctxt2 ["a"; "c"] (Bytes.of_string "Juin") in + let* ctxt4a = add ctxt3 ["a"; "d"] (Bytes.of_string "July") in + let* ctxt4b = add ctxt3 ["a"; "d"] (Bytes.of_string "Juillet") in + let* ctxt5a = add ctxt4a ["a"; "b"] (Bytes.of_string "November") in + let* novembre = find ctxt4a ["a"; "b"] in + Assert.String.Option.equal ~loc:__LOC__ (Some "Novembre") (c novembre) ; + let* november = find ctxt5a ["a"; "b"] in + Assert.String.Option.equal ~loc:__LOC__ (Some "November") (c november) ; + let* july = find ctxt5a ["a"; "d"] in + Assert.String.Option.equal ~loc:__LOC__ (Some "July") (c july) ; + let* novembre = find ctxt4b ["a"; "b"] in + Assert.String.Option.equal ~loc:__LOC__ (Some "Novembre") (c novembre) ; + let* juillet = find ctxt4b ["a"; "d"] in + Assert.String.Option.equal ~loc:__LOC__ (Some "Juillet") (c juillet) ; + Lwt.return_unit + + let fold_keys s root ~order ~init ~f = + fold s root ~order ~init ~f:(fun k v acc -> + match Tree.kind v with + | `Value -> f (root @ k) acc + | `Tree -> Lwt.return acc) + + let steps = + ["00"; "01"; "02"; "03"; "05"; "06"; "07"; "09"; "0a"; "0b"; "0c"; + "0e"; "0f"; "10"; "11"; "12"; "13"; "14"; "15"; "16"; "17"; "19"; + "1a"; "1b"; "1c"; "1d"; "1e"; "1f"; "20"; "22"; "23"; "25"; "26"; + "27"; "28"; "2a"; "2b"; "2f"; "30"; "31"; "32"; "33"; "35"; "36"; + "37"; "3a"; "3b"; "3c"; "3d"; "3e"; "3f"; "40"; "42"; "43"; "45"; + "46"; "47"; "48"; "4a"; "4b"; "4c"; "4e"; "4f"; "50"; "52"; "53"; + "54"; "55"; "56"; "57"; "59"; "5b"; "5c"; "5f"; "60"; "61"; "62"; + "63"; "64"; "65"; "66"; "67"; "69"; "6b"; "6c"; "6d"; "6e"; "6f"; + "71"; "72"; "73"; "74"; "75"; "78"; "79"; "7a"; "7b"; "7c"; "7d"; + "7e"; "80"; "82"; "83"; "84"; "85"; "86"; "88"; "8b"; "8c"; "8d"; + "8f"; "92"; "93"; "94"; "96"; "97"; "99"; "9a"; "9b"; "9d"; "9e"; + "9f"; "a0"; "a1"; "a2"; "a3"; "a4"; "a5"; "a6"; "a7"; "a8"; "aa"; + "ab"; "ac"; "ad"; "ae"; "af"; "b0"; "b1"; "b2"; "b3"; "b4"; "b6"; + "b8"; "b9"; "bb"; "bc"; "bf"; "c0"; "c1"; "c2"; "c3"; "c4"; "c5"; + "c8"; "c9"; "cb"; "cc"; "cd"; "ce"; "d0"; "d1"; "d2"; "d4"; "d5"; + "d7"; "d8"; "d9"; "da"; "e0"; "e3"; "e6"; "e8"; "e9"; "ea"; "ec"; + "ee"; "ef"; "f0"; "f1"; "f5"; "f7"; "f8"; "f9"; "fb"; "fc"; "fd"; + "fe"; "ff"] + [@@ocamlformat "disable"] + + let bindings = + let zero = Bytes.make 10 '0' in + List.map (fun x -> (["root"; x], zero)) steps + + let test_fold_keys ~order {idx; genesis; _} = + let keys t = + fold_keys t ~order ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc)) + in + let sort_keys l = + match order with + | `Sorted -> List.rev l + | `Undefined -> List.sort compare l + in + let* o = checkout idx genesis in + match o with + | None -> Assert.fail_msg "checkout genesis_block" + | Some ctxt -> + let* ctxt = add ctxt ["a"; "b"] (Bytes.of_string "Novembre") in + let* ctxt = add ctxt ["a"; "c"] (Bytes.of_string "Juin") in + let* ctxt = add ctxt ["a"; "d"; "e"] (Bytes.of_string "Septembre") in + let* ctxt = add ctxt ["f"] (Bytes.of_string "Avril") in + let* ctxt = add ctxt ["g"; "h"] (Bytes.of_string "Avril") in + let* l = keys ctxt [] in + let l = sort_keys l in + Assert.String.List_list.equal + ~loc:__LOC__ + [["a"; "b"]; ["a"; "c"]; ["a"; "d"; "e"]; ["f"]; ["g"; "h"]] + l ; + let* l = keys ctxt ["a"] in + let l = sort_keys l in + Assert.String.List_list.equal + ~loc:__LOC__ + [["a"; "b"]; ["a"; "c"]; ["a"; "d"; "e"]] + l ; + let* l = keys ctxt ["f"] in + Assert.String.List_list.equal ~loc:__LOC__ [] l ; + let* l = keys ctxt ["g"] in + Assert.String.List_list.equal ~loc:__LOC__ [["g"; "h"]] l ; + let* l = keys ctxt ["i"] in + Assert.String.List_list.equal ~loc:__LOC__ [] l ; + let* ctxt = + Lwt_list.fold_left_s (fun ctxt (k, v) -> add ctxt k v) ctxt bindings + in + let* h = commit ctxt in + let* ctxt = checkout_exn idx h in + let* bs = + fold_keys ctxt ["root"] ~order ~init:[] ~f:(fun k acc -> + Lwt.return (k :: acc)) + in + let bs = sort_keys bs in + Assert.String.List_list.equal ~loc:__LOC__ (List.map fst bindings) bs ; + Lwt.return_unit + + let test_fold_keys_sorted = test_fold_keys ~order:`Sorted + + let test_fold_keys_undefined = test_fold_keys ~order:`Undefined + + (** Checkout the context at [genesis] and fold upon a context a series of key settings. *) -let test_fold {idx; genesis; _} = - let* o = checkout idx genesis in - match o with - | None -> Assert.fail_msg "checkout genesis_block" - | Some ctxt -> - let foo1 = Bytes.of_string "foo1" in - let foo2 = Bytes.of_string "foo2" in - let* ctxt = add ctxt ["foo"; "toto"] foo1 in - let* ctxt = add ctxt ["foo"; "bar"; "toto"] foo2 in - let fold depth ecs ens = - let* cs, ns = + let test_fold {idx; genesis; _} = + let* o = checkout idx genesis in + match o with + | None -> Assert.fail_msg "checkout genesis_block" + | Some ctxt -> + let foo1 = Bytes.of_string "foo1" in + let foo2 = Bytes.of_string "foo2" in + let* ctxt = add ctxt ["foo"; "toto"] foo1 in + let* ctxt = add ctxt ["foo"; "bar"; "toto"] foo2 in + let fold depth ecs ens = + let* cs, ns = + fold + ?depth + ctxt + [] + ~order:`Sorted + ~init:([], []) + ~f:(fun path t (cs, ns) -> + match Tree.kind t with + | `Tree -> Lwt.return (cs, path :: ns) + | `Value -> Lwt.return (path :: cs, ns)) + in + Assert.String.List_list.equal ~loc:__LOC__ ecs cs ; + Assert.String.List_list.equal ~loc:__LOC__ ens ns ; + Lwt.return () + in + let* () = fold - ?depth - ctxt - [] - ~order:`Sorted - ~init:([], []) - ~f:(fun path t (cs, ns) -> - match Tree.kind t with - | `Tree -> Lwt.return (cs, path :: ns) - | `Value -> Lwt.return (path :: cs, ns)) + None + [["foo"; "toto"]; ["foo"; "bar"; "toto"]] + [["foo"; "bar"]; ["foo"]; []] in - Assert.String.List_list.equal ~loc:__LOC__ ecs cs ; - Assert.String.List_list.equal ~loc:__LOC__ ens ns ; - Lwt.return () - in - let* () = - fold - None - [["foo"; "toto"]; ["foo"; "bar"; "toto"]] - [["foo"; "bar"]; ["foo"]; []] - in - let* () = fold (Some (`Eq 0)) [] [[]] in - let* () = fold (Some (`Eq 1)) [] [["foo"]] in - let* () = fold (Some (`Eq 2)) [["foo"; "toto"]] [["foo"; "bar"]] in - let* () = fold (Some (`Lt 2)) [] [["foo"]; []] in - let* () = - fold (Some (`Le 2)) [["foo"; "toto"]] [["foo"; "bar"]; ["foo"]; []] - in - let* () = - fold - (Some (`Ge 2)) - [["foo"; "toto"]; ["foo"; "bar"; "toto"]] - [["foo"; "bar"]] - in - fold (Some (`Gt 2)) [["foo"; "bar"; "toto"]] [] - -let test_trees {idx; genesis; _} = - let* o = checkout idx genesis in - match o with - | None -> Assert.fail_msg "checkout genesis_block" - | Some ctxt -> - let* () = - Tree.fold - ~depth:(`Eq 1) - ~order:`Sorted - ~init:() - (Tree.empty ctxt) - [] - ~f:(fun k _ () -> - assert (Compare.List_length_with.(k = 1)) ; - Assert.fail_msg "empty") - in - let foo1 = Bytes.of_string "foo1" in - let foo2 = Bytes.of_string "foo2" in - Tree.empty ctxt |> fun v1 -> - let* v1 = Tree.add v1 ["foo"; "toto"] foo1 in - let* v1 = Tree.add v1 ["foo"; "bar"; "toto"] foo2 in - let fold depth ecs ens = - let* cs, ns = + let* () = fold (Some (`Eq 0)) [] [[]] in + let* () = fold (Some (`Eq 1)) [] [["foo"]] in + let* () = fold (Some (`Eq 2)) [["foo"; "toto"]] [["foo"; "bar"]] in + let* () = fold (Some (`Lt 2)) [] [["foo"]; []] in + let* () = + fold (Some (`Le 2)) [["foo"; "toto"]] [["foo"; "bar"]; ["foo"]; []] + in + let* () = + fold + (Some (`Ge 2)) + [["foo"; "toto"]; ["foo"; "bar"; "toto"]] + [["foo"; "bar"]] + in + fold (Some (`Gt 2)) [["foo"; "bar"; "toto"]] [] + + let test_trees {idx; genesis; _} = + let* o = checkout idx genesis in + match o with + | None -> Assert.fail_msg "checkout genesis_block" + | Some ctxt -> + let* () = Tree.fold - v1 - ?depth - [] + ~depth:(`Eq 1) ~order:`Sorted - ~init:([], []) - ~f:(fun path t (cs, ns) -> - match Tree.kind t with - | `Tree -> Lwt.return (cs, path :: ns) - | `Value -> Lwt.return (path :: cs, ns)) + ~init:() + (Tree.empty ctxt) + [] + ~f:(fun k _ () -> + assert (Compare.List_length_with.(k = 1)) ; + Assert.fail_msg "empty") + in + let foo1 = Bytes.of_string "foo1" in + let foo2 = Bytes.of_string "foo2" in + Tree.empty ctxt |> fun v1 -> + let* v1 = Tree.add v1 ["foo"; "toto"] foo1 in + let* v1 = Tree.add v1 ["foo"; "bar"; "toto"] foo2 in + let fold depth ecs ens = + let* cs, ns = + Tree.fold + v1 + ?depth + [] + ~order:`Sorted + ~init:([], []) + ~f:(fun path t (cs, ns) -> + match Tree.kind t with + | `Tree -> Lwt.return (cs, path :: ns) + | `Value -> Lwt.return (path :: cs, ns)) + in + Assert.String.List_list.equal ~loc:__LOC__ ecs cs ; + Assert.String.List_list.equal ~loc:__LOC__ ens ns ; + Lwt.return () + in + let* () = + fold + None + [["foo"; "toto"]; ["foo"; "bar"; "toto"]] + [["foo"; "bar"]; ["foo"]; []] + in + let* () = fold (Some (`Eq 0)) [] [[]] in + let* () = fold (Some (`Eq 1)) [] [["foo"]] in + let* () = fold (Some (`Eq 2)) [["foo"; "toto"]] [["foo"; "bar"]] in + let* () = fold (Some (`Lt 2)) [] [["foo"]; []] in + let* () = + fold (Some (`Le 2)) [["foo"; "toto"]] [["foo"; "bar"]; ["foo"]; []] in - Assert.String.List_list.equal ~loc:__LOC__ ecs cs ; - Assert.String.List_list.equal ~loc:__LOC__ ens ns ; + let* () = + fold + (Some (`Ge 2)) + [["foo"; "toto"]; ["foo"; "bar"; "toto"]] + [["foo"; "bar"]] + in + let* () = fold (Some (`Gt 2)) [["foo"; "bar"; "toto"]] [] in + let* v1 = Tree.remove v1 ["foo"; "bar"; "toto"] in + let* v = Tree.find v1 ["foo"; "bar"; "toto"] in + Assert.Bytes.Option.equal ~loc:__LOC__ None v ; + let* v = Tree.find v1 ["foo"; "toto"] in + Assert.Bytes.Option.equal ~loc:__LOC__ (Some foo1) v ; + Tree.empty ctxt |> fun v1 -> + let* v1 = Tree.add v1 ["foo"; "1"] foo1 in + let* v1 = Tree.add v1 ["foo"; "2"] foo2 in + let* v1 = Tree.remove v1 ["foo"; "1"] in + let* v1 = Tree.remove v1 ["foo"; "2"] in + let* v = Tree.find v1 ["foo"; "1"] in + Assert.Bytes.Option.equal ~loc:__LOC__ None v ; + let* v1 = Tree.remove v1 [] in + Assert.Bool.equal ~loc:__LOC__ true (Tree.is_empty v1) ; + Lwt.return () + + let test_raw {idx; genesis; _} = + let* o = checkout idx genesis in + match o with + | None -> Assert.fail_msg "checkout genesis_block" + | Some ctxt -> + let foo1 = Bytes.of_string "foo1" in + let foo2 = Bytes.of_string "foo2" in + let* ctxt = add ctxt ["foo"; "toto"] foo1 in + let* ctxt = add ctxt ["foo"; "bar"; "toto"] foo2 in + let* tree = find_tree ctxt [] in + let tree = WithExceptions.Option.get ~loc:__LOC__ tree in + let* raw = Tree.to_raw tree in + let a = String.Map.singleton "toto" (`Value foo1) in + let b = String.Map.singleton "toto" (`Value foo2) in + let c = String.Map.add "bar" (`Tree b) a in + let d = String.Map.singleton "foo" (`Tree c) in + let e = `Tree d in + Assert_lib.Raw_Tree.equal ~loc:__LOC__ e raw ; + Lwt.return () + + let string n = String.make n 'a' + + let test_encoding {idx; genesis; _} = + let* o = checkout idx genesis in + match o with + | None -> Assert.fail_msg "checkout genesis_block" + | Some ctxt -> + let foo1 = Bytes.of_string "foo1" in + let foo2 = Bytes.of_string "foo2" in + let* ctxt = add ctxt ["a"; string 7] foo1 in + let* ctxt = add ctxt ["a"; string 8] foo2 in + let* ctxt = add ctxt [string 16] foo2 in + let* ctxt = add ctxt [string 32] foo2 in + let* ctxt = add ctxt [string 64] foo2 in + let* ctxt = add ctxt [string 127] foo2 in + let* h = commit ctxt in + equal_context_hash + ~loc:__LOC__ + (Context_hash.of_b58check_exn + "CoWJsL2ehZ39seTr8inBCJb5tVjW8KGNweJ5cvuVq51mAASrRmim") + h ; + let* ctxt = add ctxt [string 255] foo2 in + let* h = commit ctxt in + equal_context_hash + ~loc:__LOC__ + (Context_hash.of_b58check_exn + "CoVexcEHMXmSA2k42aNc5MCDtVJFRs3CC6vcQWYwFoj7EFsBPw1c") + h ; Lwt.return () - in - let* () = - fold - None - [["foo"; "toto"]; ["foo"; "bar"; "toto"]] - [["foo"; "bar"]; ["foo"]; []] - in - let* () = fold (Some (`Eq 0)) [] [[]] in - let* () = fold (Some (`Eq 1)) [] [["foo"]] in - let* () = fold (Some (`Eq 2)) [["foo"; "toto"]] [["foo"; "bar"]] in - let* () = fold (Some (`Lt 2)) [] [["foo"]; []] in - let* () = - fold (Some (`Le 2)) [["foo"; "toto"]] [["foo"; "bar"]; ["foo"]; []] - in - let* () = - fold - (Some (`Ge 2)) - [["foo"; "toto"]; ["foo"; "bar"; "toto"]] - [["foo"; "bar"]] - in - let* () = fold (Some (`Gt 2)) [["foo"; "bar"; "toto"]] [] in - let* v1 = Tree.remove v1 ["foo"; "bar"; "toto"] in - let* v = Tree.find v1 ["foo"; "bar"; "toto"] in - Assert.Bytes.Option.equal ~loc:__LOC__ None v ; - let* v = Tree.find v1 ["foo"; "toto"] in - Assert.Bytes.Option.equal ~loc:__LOC__ (Some foo1) v ; - Tree.empty ctxt |> fun v1 -> - let* v1 = Tree.add v1 ["foo"; "1"] foo1 in - let* v1 = Tree.add v1 ["foo"; "2"] foo2 in - let* v1 = Tree.remove v1 ["foo"; "1"] in - let* v1 = Tree.remove v1 ["foo"; "2"] in - let* v = Tree.find v1 ["foo"; "1"] in - Assert.Bytes.Option.equal ~loc:__LOC__ None v ; - let* v1 = Tree.remove v1 [] in - Assert.Bool.equal ~loc:__LOC__ true (Tree.is_empty v1) ; - Lwt.return () - -let test_raw {idx; genesis; _} = - let* o = checkout idx genesis in - match o with - | None -> Assert.fail_msg "checkout genesis_block" - | Some ctxt -> - let foo1 = Bytes.of_string "foo1" in - let foo2 = Bytes.of_string "foo2" in - let* ctxt = add ctxt ["foo"; "toto"] foo1 in - let* ctxt = add ctxt ["foo"; "bar"; "toto"] foo2 in - let* tree = find_tree ctxt [] in - let tree = WithExceptions.Option.get ~loc:__LOC__ tree in - let* raw = Tree.to_raw tree in - let a = String.Map.singleton "toto" (`Value foo1) in - let b = String.Map.singleton "toto" (`Value foo2) in - let c = String.Map.add "bar" (`Tree b) a in - let d = String.Map.singleton "foo" (`Tree c) in - let e = `Tree d in - Assert_lib.Raw_Tree.equal ~loc:__LOC__ e raw ; - Lwt.return () - -let string n = String.make n 'a' - -let test_encoding {idx; genesis; _} = - let* o = checkout idx genesis in - match o with - | None -> Assert.fail_msg "checkout genesis_block" - | Some ctxt -> - let foo1 = Bytes.of_string "foo1" in - let foo2 = Bytes.of_string "foo2" in - let* ctxt = add ctxt ["a"; string 7] foo1 in - let* ctxt = add ctxt ["a"; string 8] foo2 in - let* ctxt = add ctxt [string 16] foo2 in - let* ctxt = add ctxt [string 32] foo2 in - let* ctxt = add ctxt [string 64] foo2 in - let* ctxt = add ctxt [string 127] foo2 in - let* h = commit ctxt in - equal_context_hash - ~loc:__LOC__ - (Context_hash.of_b58check_exn - "CoWJsL2ehZ39seTr8inBCJb5tVjW8KGNweJ5cvuVq51mAASrRmim") - h ; - let* ctxt = add ctxt [string 255] foo2 in - let* h = commit ctxt in - equal_context_hash - ~loc:__LOC__ - (Context_hash.of_b58check_exn - "CoVexcEHMXmSA2k42aNc5MCDtVJFRs3CC6vcQWYwFoj7EFsBPw1c") - h ; - Lwt.return () - -(** Exports to a dump file the context reached at block [block2b]. + + let test_is_empty {idx; block2; _} = + let* o = checkout idx block2 in + match o with + | None -> Assert.fail_msg "checkout block2" + | Some ctxt -> ( + (* By [create_block2] above, [ctxt] maps "a/b", "a/c", and "version" *) + let etree = Context.Tree.empty ctxt in + Assert.Bool.equal true (Tree.is_empty etree) ; + let* o = Context.find_tree ctxt ["a"] in + match o with + | None -> Assert.fail_msg "dir 'a/' not found" + | Some dir_a -> + let* dir_a = Tree.remove dir_a ["b"] in + let* dir_a = Tree.remove dir_a ["c"] in + let* ls = Tree.list dir_a [] in + let assert_equal_ls = + Assert.equal_list ~loc:__LOC__ ~eq:( = ) ~pp:(fun ppf e -> + Format.pp_print_string ppf (fst e)) + in + assert_equal_ls + ~msg:"length of directory /a/ is unexpectedly not 0" + [] + ls ; + equal_context_hash + ~loc:__LOC__ + ~msg: + "A fresh empty tree has the same hash as a tree containing \ + data after removing all its data" + (Tree.hash etree) + (Tree.hash dir_a) ; + Assert.Bool.equal + ~loc:__LOC__ + ~msg:"directory /a/ is unexpectedly not empty" + true + (Context.Tree.is_empty dir_a) ; + Lwt.return_unit) + + (** Test that [get_hash_version succeeds] *) + let test_get_version_hash {idx; block2; _} = + let+ ctxt = Context.checkout_exn idx block2 in + let _ = get_hash_version ctxt in + () + + (** Test [set_hash_version] on values on which it goes into the error monad *) + let test_set_version_hash_tzresult {idx; block2; _} = + List.iter_s + (fun wrong_version -> + let* ctxt = Context.checkout_exn idx block2 in + let+ r = + set_hash_version ctxt @@ Context_hash.Version.of_int wrong_version + in + match r with + | Ok _ -> + Assert.fail_msg "set_hash_version should have returned Error _" + | Error _ -> ()) + (* Only version 0 is supported atm *) + [1; 2; 256] + + let test_to_memory_tree {idx; block2; _} : unit Lwt.t = + let open Lwt_syntax in + let* ctxt = Context.checkout_exn idx block2 in + let* tree = Context.to_memory_tree ctxt ["a"; "b"] in + let () = Assert.Bool.equal true (Option.is_some tree) in + let* tree = Context.to_memory_tree ctxt ["a"; "x"] in + let () = Assert.Bool.equal true (Option.is_none tree) in + return_unit + + let tree_of_list ls {idx; _} = + let ctxt = Context.empty idx in + let tree = Tree.empty ctxt in + Lwt_list.fold_left_s (fun tree (k, v) -> Tree.add tree k v) tree ls + + let hash_of_contents tree key = + let* tree = Tree.find_tree tree key in + match tree with + | None -> Assert.fail_msg "contents not found in tree" + | Some t -> Lwt.return (Tree.hash t) + + let test_proof_exn ctxt = + let open Lwt_syntax in + let open Context.Proof in + let bytes s = Bytes.of_string s in + let x = bytes "x" in + let y = bytes "y" in + let* tree = tree_of_list [(["bx"], x); (["by"], y)] ctxt in + let hash = Tree.hash tree in + let* hx = hash_of_contents tree ["bx"] in + let* hy = hash_of_contents tree ["by"] in + let stream_elt1 : Stream.elt = Value y in + let stream_elt2 : Stream.elt = Value x in + let stream_elt3 : Stream.elt = + Node [("bx", `Value hx); ("by", `Value hy)] + in + let stream_all = + { + version = 1; + before = `Node hash; + after = `Node hash; + state = List.to_seq [stream_elt3; stream_elt2; stream_elt1]; + } + in + let stream_short = + { + version = 1; + before = `Node hash; + after = `Node hash; + state = List.to_seq [stream_elt3; stream_elt2]; + } + in + let f_all t = + let* _ = Context.Tree.find t ["bx"] in + let+ _ = Context.Tree.find t ["by"] in + (t, ()) + in + let f_short t = + let+ _ = Context.Tree.find t ["bx"] in + (t, ()) + in + (* Test the Stream_too_long error. *) + let* r = Context.verify_stream_proof stream_all f_short in + let* () = + match r with + | Error (`Stream_too_long _) -> Lwt.return_unit + | _ -> Assert.fail_msg "expected Stream_too_long error" + in + (* Test the Stream_too_short error. *) + let* r = Context.verify_stream_proof stream_short f_all in + let* () = + match r with + | Error (`Stream_too_short _) -> Lwt.return_unit + | _ -> Assert.fail_msg "expected Stream_too_short error" + in + (* Test the correct usecase. *) + let* r = Context.verify_stream_proof stream_all f_all in + let* () = + match r with + | Ok (_, ()) -> return_unit + | Error e -> ( + match e with + | `Proof_mismatch str -> + Assert.fail_msg "unexpected Proof_mismatch error: %s" str + | `Stream_too_long str -> + Assert.fail_msg "unexpected Stream_too_long error: %s" str + | `Stream_too_short str -> + Assert.fail_msg "unexpected Stream_too_short error: %s" str) + in + return_unit + + (******************************************************************************) + + let tests : (string * (t -> unit Lwt.t) * init_config option) list = + let test ?config name f = + (Printf.sprintf "%s:%s" Tag.tag name, f, config) + in + [ + test "is_empty" test_is_empty; + test "simple" test_simple; + test "list" test_list; + test "continuation" test_continuation; + test "fork" test_fork; + test "replay" test_replay; + test "fold_keys_sorted" test_fold_keys_sorted; + test "fold_keys_undefined" test_fold_keys_undefined; + test "fold" test_fold; + test "trees" test_trees; + test "raw" test_raw; + (* NOTE: importing the context from a snapshot requires using an [`Always] + indexing strategy. See the docs for [Context.restore_context] for more + details. *) + test "encoding" test_encoding; + test "get_hash_version" test_get_version_hash; + test "set_hash_version_tzresult" test_set_version_hash_tzresult; + test "to_memory_tree" test_to_memory_tree; + test "proof exn" test_proof_exn; + ] + + let tests = + List.map + (fun (s, f, config) -> + Alcotest_lwt.test_case s `Quick (wrap_context_init config f)) + tests +end + +(* Tests for contexts satisfying TEZOS_CONTEXT_UNIX *) +module Make_unix (Tag : sig + val tag : string +end) +(Context : Tezos_context_disk.TEZOS_CONTEXT_UNIX) = +struct + open Context + + (** Context creation *) + + let commit = commit ~time:Time.Protocol.epoch ~message:"" + + let create_block2 idx genesis_commit = + let* o = checkout idx genesis_commit in + match o with + | None -> Assert.fail_msg "checkout genesis_block" + | Some ctxt -> + let* ctxt = add ctxt ["a"; "b"] (Bytes.of_string "Novembre") in + let* ctxt = add ctxt ["a"; "c"] (Bytes.of_string "Juin") in + let* ctxt = add ctxt ["version"] (Bytes.of_string "0.0") in + commit ctxt + + let create_block3a idx block2_commit = + let* o = checkout idx block2_commit in + match o with + | None -> Assert.fail_msg "checkout block2" + | Some ctxt -> + let* ctxt = remove ctxt ["a"; "b"] in + let* ctxt = add ctxt ["a"; "d"] (Bytes.of_string "Mars") in + commit ctxt + + let create_block3b idx block2_commit = + let* o = checkout idx block2_commit in + match o with + | None -> Assert.fail_msg "checkout block3b" + | Some ctxt -> + let* ctxt = remove ctxt ["a"; "c"] in + let* ctxt = add ctxt ["a"; "d"] (Bytes.of_string "Février") in + commit ctxt + + type t = { + idx : Context.index; + genesis : Context_hash.t; + block2 : Context_hash.t; + block3a : Context_hash.t; + block3b : Context_hash.t; + } + + type init_config = {indexing_strategy : [`Always | `Minimal]} + + let wrap_context_init config f _ () = + Lwt_utils_unix.with_tempdir "tezos_test_" (fun base_dir -> + let root = base_dir // "context" in + let* idx = + match config with + | None -> Context.init root + | Some {indexing_strategy} -> Context.init ~indexing_strategy root + in + let*!! genesis = + Context.commit_genesis + idx + ~chain_id + ~time:genesis_time + ~protocol:genesis_protocol + in + let* block2 = create_block2 idx genesis in + let* block3a = create_block3a idx block2 in + let* block3b = create_block3b idx block2 in + f {idx; genesis; block2; block3a; block3b}) + + (** Exports to a dump file the context reached at block [block2b]. After importing it, it is asserted that the context hash is preserved. *) -let test_dump {idx; block3b; _} = - let*!! () = - Lwt_utils_unix.with_tempdir "tezos_test_" (fun base_dir2 -> - let open Lwt_result_syntax in - let dumpfile = base_dir2 // "dump" in - let ctxt_hash = block3b in - let mk_empty_block_header context = - Block_header. - { - protocol_data = Bytes.empty; - shell = - { - level = 0l; - proto_level = 0; - predecessor = Block_hash.zero; - timestamp = Time.Protocol.epoch; - validation_passes = 0; - operations_hash = Operation_list_list_hash.zero; - fitness = []; - context; - }; - } - in - let empty_block_header = mk_empty_block_header ctxt_hash in - let nb_context_elements = 0 in - let target_context_hash = empty_block_header.shell.context in - let* _ = + let test_dump {idx; block3b; _} = + let*!! () = + Lwt_utils_unix.with_tempdir "tezos_test_" (fun base_dir2 -> + let open Lwt_result_syntax in + let dumpfile = base_dir2 // "dump" in + let ctxt_hash = block3b in + let mk_empty_block_header context = + Block_header. + { + protocol_data = Bytes.empty; + shell = + { + level = 0l; + proto_level = 0; + predecessor = Block_hash.zero; + timestamp = Time.Protocol.epoch; + validation_passes = 0; + operations_hash = Operation_list_list_hash.zero; + fitness = []; + context; + }; + } + in + let empty_block_header = mk_empty_block_header ctxt_hash in + let nb_context_elements = 0 in + let target_context_hash = empty_block_header.shell.context in + let* _ = + let*! context_fd = + Lwt_unix.openfile + dumpfile + Lwt_unix.[O_WRONLY; O_CREAT; O_TRUNC] + 0o644 + in + Lwt.finalize + (fun () -> + Context.dump_context + ~on_disk:false + idx + target_context_hash + ~fd:context_fd + ~progress_display_mode:Animation.Auto) + (fun () -> Lwt_unix.close context_fd) + in + let root = base_dir2 // "context" in + let*! idx2 = + Context.init ~indexing_strategy:`Always ?patch_context:None root + in let*! context_fd = - Lwt_unix.openfile - dumpfile - Lwt_unix.[O_WRONLY; O_CREAT; O_TRUNC] - 0o644 + Lwt_unix.openfile dumpfile Lwt_unix.[O_RDONLY] 0o444 in Lwt.finalize (fun () -> - Context.dump_context - ~on_disk:false - idx - target_context_hash + Context.restore_context + idx2 + ~expected_context_hash:target_context_hash + ~nb_context_elements ~fd:context_fd + ~legacy:false + ~in_memory:true ~progress_display_mode:Animation.Auto) - (fun () -> Lwt_unix.close context_fd) - in - let root = base_dir2 // "context" in - let*! idx2 = - Context.init ~indexing_strategy:`Always ?patch_context:None root - in - let*! context_fd = - Lwt_unix.openfile dumpfile Lwt_unix.[O_RDONLY] 0o444 - in - Lwt.finalize - (fun () -> - Context.restore_context - idx2 - ~expected_context_hash:target_context_hash - ~nb_context_elements - ~fd:context_fd - ~legacy:false - ~in_memory:true - ~progress_display_mode:Animation.Auto) - (fun () -> Lwt_unix.close context_fd)) - in - Lwt.return_unit - -let test_is_empty {idx; block2; _} = - let* o = checkout idx block2 in - match o with - | None -> Assert.fail_msg "checkout block2" - | Some ctxt -> ( - (* By [create_block2] above, [ctxt] maps "a/b", "a/c", and "version" *) - let etree = Context.Tree.empty ctxt in - Assert.Bool.equal true (Tree.is_empty etree) ; - let* o = Context.find_tree ctxt ["a"] in - match o with - | None -> Assert.fail_msg "dir 'a/' not found" - | Some dir_a -> - let* dir_a = Tree.remove dir_a ["b"] in - let* dir_a = Tree.remove dir_a ["c"] in - let* ls = Tree.list dir_a [] in - let assert_equal_ls = - Assert.equal_list ~loc:__LOC__ ~eq:( = ) ~pp:(fun ppf e -> - Format.pp_print_string ppf (fst e)) - in - assert_equal_ls - ~msg:"length of directory /a/ is unexpectedly not 0" - [] - ls ; - equal_context_hash - ~loc:__LOC__ - ~msg: - "A fresh empty tree has the same hash as a tree containing data \ - after removing all its data" - (Tree.hash etree) - (Tree.hash dir_a) ; - Assert.Bool.equal - ~loc:__LOC__ - ~msg:"directory /a/ is unexpectedly not empty" - true - (Context.Tree.is_empty dir_a) ; - Lwt.return_unit) - -(** Test that [get_hash_version succeeds] *) -let test_get_version_hash {idx; block2; _} = - let+ ctxt = Context.checkout_exn idx block2 in - let _ = get_hash_version ctxt in - () - -(** Test [set_hash_version] on values on which it goes into the error monad *) -let test_set_version_hash_tzresult {idx; block2; _} = - List.iter_s - (fun wrong_version -> - let* ctxt = Context.checkout_exn idx block2 in - let+ r = - set_hash_version ctxt @@ Context_hash.Version.of_int wrong_version - in - match r with - | Ok _ -> Assert.fail_msg "set_hash_version should have returned Error _" - | Error _ -> ()) - (* Only version 0 is supported atm *) - [1; 2; 256] - -let test_to_memory_tree {idx; block2; _} : unit Lwt.t = - let open Lwt_syntax in - let* ctxt = Context.checkout_exn idx block2 in - let* tree = Context.to_memory_tree ctxt ["a"; "b"] in - let () = Assert.Bool.equal true (Option.is_some tree) in - let* tree = Context.to_memory_tree ctxt ["a"; "x"] in - let () = Assert.Bool.equal true (Option.is_none tree) in - return_unit - -let tree_of_list ls {idx; _} = - let ctxt = Context.empty idx in - let tree = Tree.empty ctxt in - Lwt_list.fold_left_s (fun tree (k, v) -> Tree.add tree k v) tree ls - -let hash_of_contents tree key = - let* tree = Tree.find_tree tree key in - match tree with - | None -> Assert.fail_msg "contents not found in tree" - | Some t -> Lwt.return (Tree.hash t) - -let test_proof_exn ctxt = - let open Lwt_syntax in - let open Context.Proof in - let bytes s = Bytes.of_string s in - let x = bytes "x" in - let y = bytes "y" in - let* tree = tree_of_list [(["bx"], x); (["by"], y)] ctxt in - let hash = Tree.hash tree in - let* hx = hash_of_contents tree ["bx"] in - let* hy = hash_of_contents tree ["by"] in - let stream_elt1 : Stream.elt = Value y in - let stream_elt2 : Stream.elt = Value x in - let stream_elt3 : Stream.elt = Node [("bx", `Value hx); ("by", `Value hy)] in - let stream_all = - { - version = 1; - before = `Node hash; - after = `Node hash; - state = List.to_seq [stream_elt3; stream_elt2; stream_elt1]; - } - in - let stream_short = - { - version = 1; - before = `Node hash; - after = `Node hash; - state = List.to_seq [stream_elt3; stream_elt2]; - } - in - let f_all t = - let* _ = Context.Tree.find t ["bx"] in - let+ _ = Context.Tree.find t ["by"] in - (t, ()) - in - let f_short t = - let+ _ = Context.Tree.find t ["bx"] in - (t, ()) - in - (* Test the Stream_too_long error. *) - let* r = Context.verify_stream_proof stream_all f_short in - let* () = - match r with - | Error (`Stream_too_long _) -> Lwt.return_unit - | _ -> Assert.fail_msg "expected Stream_too_long error" - in - (* Test the Stream_too_short error. *) - let* r = Context.verify_stream_proof stream_short f_all in - let* () = - match r with - | Error (`Stream_too_short _) -> Lwt.return_unit - | _ -> Assert.fail_msg "expected Stream_too_short error" - in - (* Test the correct usecase. *) - let* r = Context.verify_stream_proof stream_all f_all in - let* () = - match r with - | Ok (_, ()) -> return_unit - | Error e -> ( - match e with - | `Proof_mismatch str -> - Assert.fail_msg "unexpected Proof_mismatch error: %s" str - | `Stream_too_long str -> - Assert.fail_msg "unexpected Stream_too_long error: %s" str - | `Stream_too_short str -> - Assert.fail_msg "unexpected Stream_too_short error: %s" str) - in - return_unit - -(******************************************************************************) - -let tests : (string * (t -> unit Lwt.t) * init_config option) list = - let test ?config name f = (name, f, config) in - [ - test "is_empty" test_is_empty; - test "simple" test_simple; - test "list" test_list; - test "continuation" test_continuation; - test "fork" test_fork; - test "replay" test_replay; - test "fold_keys_sorted" test_fold_keys_sorted; - test "fold_keys_undefined" test_fold_keys_undefined; - test "fold" test_fold; - test "trees" test_trees; - test "raw" test_raw; - (* NOTE: importing the context from a snapshot requires using an [`Always] - indexing strategy. See the docs for [Context.restore_context] for more - details. *) - test ~config:{indexing_strategy = `Always} "dump" test_dump; - test "encoding" test_encoding; - test "get_hash_version" test_get_version_hash; - test "set_hash_version_tzresult" test_set_version_hash_tzresult; - test "to_memory_tree" test_to_memory_tree; - test "proof exn" test_proof_exn; - ] + (fun () -> Lwt_unix.close context_fd)) + in + Lwt.return_unit + + (******************************************************************************) + + let tests : (string * (t -> unit Lwt.t) * init_config option) list = + let test ?config name f = + (Printf.sprintf "%s:%s" Tag.tag name, f, config) + in + [ + (* NOTE: importing the context from a snapshot requires using an [`Always] + indexing strategy. See the docs for [Context.restore_context] for more + details. *) + test ~config:{indexing_strategy = `Always} "dump" test_dump; + ] + + let tests = + List.map + (fun (s, f, config) -> + Alcotest_lwt.test_case s `Quick (wrap_context_init config f)) + tests +end + +module Generic_disk = + Make_generic + (struct + let tag = "disk" + end) + (struct + type memory_context_tree = Tezos_context_memory.Context.tree + end) + (Tezos_context_disk.Context) + +module Generic_memory = + Make_generic + (struct + let tag = "memory" + end) + (struct + type memory_context_tree = Tezos_context_memory.Context.tree + end) + (Tezos_context_memory.Context) + +module Unix_disk = + Make_unix + (struct + let tag = "disk" + end) + (Tezos_context_disk.Context) let tests = - List.map - (fun (s, f, config) -> - Alcotest_lwt.test_case s `Quick (wrap_context_init config f)) - tests + List.concat [Generic_disk.tests; Generic_memory.tests; Unix_disk.tests] -- GitLab From bf1b20d0f461d498a5aade99c9d96743d838156a Mon Sep 17 00:00:00 2001 From: vbot Date: Mon, 13 Jun 2022 11:44:24 -0700 Subject: [PATCH 11/11] manifest: fix manifest --- .gitlab/ci/opam-ci.yml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.gitlab/ci/opam-ci.yml b/.gitlab/ci/opam-ci.yml index 38128fbe3ec6..83448d9db231 100644 --- a/.gitlab/ci/opam-ci.yml +++ b/.gitlab/ci/opam-ci.yml @@ -910,14 +910,14 @@ opam:tezos-protocol-006-PsCARTHA: opam:tezos-protocol-007-PsDELPH1: extends: - .opam_template - - .rules_template__trigger_opam_batch_5 + - .rules_template__trigger_opam_batch_4 variables: package: tezos-protocol-007-PsDELPH1 opam:tezos-protocol-008-PtEdo2Zk: extends: - .opam_template - - .rules_template__trigger_opam_batch_4 + - .rules_template__trigger_opam_batch_5 variables: package: tezos-protocol-008-PtEdo2Zk @@ -1421,7 +1421,7 @@ opam:tezos-webassembly-interpreter: opam:tezos-workers: extends: - .opam_template - - .rules_template__trigger_opam_batch_5 + - .rules_template__trigger_opam_batch_6 variables: package: tezos-workers -- GitLab