From 86acb4a8ab1c33b28b64ec9ba46fb45f89495915 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Thu, 4 Apr 2024 16:34:16 +0200 Subject: [PATCH 1/3] irmin/test: import irmin_test lib --- irmin/test/helpers/common.ml | 331 ++++ irmin/test/helpers/helpers.ml | 19 + irmin/test/helpers/import.ml | 18 + irmin/test/helpers/irmin_test.ml | 20 + irmin/test/helpers/irmin_test.mli | 74 + irmin/test/helpers/node.ml | 150 ++ irmin/test/helpers/rusage.ml | 38 + irmin/test/helpers/rusage_stubs.c | 57 + irmin/test/helpers/store.ml | 2494 ++++++++++++++++++++++++++++ irmin/test/helpers/store.mli | 24 + irmin/test/helpers/store_graph.ml | 209 +++ irmin/test/helpers/store_graph.mli | 17 + irmin/test/helpers/store_watch.ml | 379 +++++ irmin/test/helpers/store_watch.mli | 17 + 14 files changed, 3847 insertions(+) create mode 100644 irmin/test/helpers/common.ml create mode 100644 irmin/test/helpers/helpers.ml create mode 100644 irmin/test/helpers/import.ml create mode 100644 irmin/test/helpers/irmin_test.ml create mode 100644 irmin/test/helpers/irmin_test.mli create mode 100644 irmin/test/helpers/node.ml create mode 100644 irmin/test/helpers/rusage.ml create mode 100644 irmin/test/helpers/rusage_stubs.c create mode 100644 irmin/test/helpers/store.ml create mode 100644 irmin/test/helpers/store.mli create mode 100644 irmin/test/helpers/store_graph.ml create mode 100644 irmin/test/helpers/store_graph.mli create mode 100644 irmin/test/helpers/store_watch.ml create mode 100644 irmin/test/helpers/store_watch.mli diff --git a/irmin/test/helpers/common.ml b/irmin/test/helpers/common.ml new file mode 100644 index 000000000000..3ccc8330b9d9 --- /dev/null +++ b/irmin/test/helpers/common.ml @@ -0,0 +1,331 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +let random_char () = char_of_int (Random.int 256) + +let random_ascii () = + let chars = "0123456789abcdefghijklmnopqrstABCDEFGHIJKLMNOPQRST-_." in + chars.[Random.int @@ String.length chars] + +let random_string n = String.init n (fun _i -> random_char ()) +let long_random_string = random_string (* 1024_000 *) 10 +let random_ascii_string n = String.init n (fun _i -> random_ascii ()) +let long_random_ascii_string = random_ascii_string 1024_000 + +let merge_exn msg x = + match x with + | Ok x -> Lwt.return x + | Error (`Conflict m) -> Alcotest.failf "%s: %s" msg m + +open Astring + +module type S = + Irmin.S + with type Schema.Path.step = string + and type Schema.Path.t = string list + and type Schema.Contents.t = string + and type Schema.Branch.t = string + +module type Generic_key = + Irmin.Generic_key.S + with type Schema.Path.step = string + and type Schema.Path.t = string list + and type Schema.Contents.t = string + and type Schema.Branch.t = string + +module Schema = struct + module Hash = Irmin.Hash.SHA1 + module Commit = Irmin.Commit.Make (Hash) + module Path = Irmin.Path.String_list + module Metadata = Irmin.Metadata.None + module Node = Irmin.Node.Generic_key.Make (Hash) (Path) (Metadata) + module Branch = Irmin.Branch.String + module Info = Irmin.Info.Default + module Contents = Irmin.Contents.String +end + +let store : (module Irmin.Maker) -> (module Irmin.Metadata.S) -> (module S) = + fun (module B) (module M) -> + let module Schema = struct + include Schema + module Metadata = M + module Node = Irmin.Node.Generic_key.Make (Hash) (Path) (Metadata) + end in + let module S = B.Make (Schema) in + (module S) + +type store = S of (module S) | Generic_key of (module Generic_key) + +type t = { + name : string; + init : config:Irmin.config -> unit Lwt.t; + clean : config:Irmin.config -> unit Lwt.t; + config : Irmin.config; + store : store; + stats : (unit -> int * int) option; + (* Certain store implementations currently don't support implementing + repository state from a slice, because their slice formats contain + non-portable objects. For now, we disable the tests require this feature + for such backends. + + TODO: fix slices to always contain portable objects, and extend + [Store.import] to re-hydrate the keys in these slices (by tracking keys of + added objects), then require all backends to run thee tests. *) + import_supported : bool; +} + +module Suite = struct + type nonrec t = t + + let default_clean ~config ~store = + let (module Store : Generic_key) = + match store with + | Generic_key x -> x + | S (module S) -> (module S : Generic_key) + in + let open Lwt.Syntax in + let* repo = Store.Repo.v config in + let* branches = Store.Repo.branches repo in + let* () = Lwt_list.iter_p (Store.Branch.remove repo) branches in + Store.Repo.close repo + + let create ~name ?(init = fun ~config:_ -> Lwt.return_unit) ?clean ~config + ~store ?stats ?(import_supported = true) () = + let store = S store in + let clean = Option.value clean ~default:(default_clean ~store) in + { name; init; clean; config; store; stats; import_supported } + + let create_generic_key ~name ?(init = fun ~config:_ -> Lwt.return_unit) ?clean + ~config ~store ?stats ?(import_supported = true) () = + let store = Generic_key store in + let clean = Option.value clean ~default:(default_clean ~store) in + { name; init; clean; config; store; stats; import_supported } + + let name t = t.name + let config t = t.config + let store t = match t.store with S x -> Some x | Generic_key _ -> None + + let store_generic_key t = + match t.store with + | Generic_key x -> x + | S (module S) -> (module S : Generic_key) + + let init t = t.init + let clean t = t.clean +end + +module type Store_tests = functor (S : Generic_key) -> sig + val tests : (string * (Suite.t -> unit -> unit Lwt.t)) list +end + +module Make_helpers (S : Generic_key) = struct + module B = S.Backend + module Graph = Irmin.Node.Graph (B.Node) + + let info message = + let date = Int64.of_float 0. in + let author = Printf.sprintf "TESTS" in + S.Info.v ~author ~message date + + let infof fmt = Fmt.kstr (fun str () -> info str) fmt + + let get_contents_key = function + | `Contents key -> key + | _ -> Alcotest.fail "expecting contents_key" + + let get_node_key = function + | `Node key -> key + | _ -> Alcotest.fail "expecting node_key" + + type x = int [@@deriving irmin] + + let v repo = B.Repo.contents_t repo + let n repo = B.Repo.node_t repo + let ct repo = B.Repo.commit_t repo + let g repo = B.Repo.node_t repo + let h repo = B.Repo.commit_t repo + let b repo = B.Repo.branch_t repo + let v1 = long_random_string + let v2 = "" + let with_contents repo f = B.Repo.batch repo (fun t _ _ -> f t) + let with_node repo f = B.Repo.batch repo (fun _ t _ -> f t) + let with_commit repo f = B.Repo.batch repo (fun _ _ t -> f t) + let with_info repo n f = with_commit repo (fun h -> f h ~info:(info n)) + let kv1 ~repo = with_contents repo (fun t -> B.Contents.add t v1) + let kv2 ~repo = with_contents repo (fun t -> B.Contents.add t v2) + let normal x = `Contents (x, S.Metadata.default) + let b1 = "foo" + let b2 = "bar/toto" + + let n1 ~repo = + let* kv1 = kv1 ~repo in + with_node repo (fun t -> Graph.v t [ ("x", normal kv1) ]) + + let n2 ~repo = + let* kn1 = n1 ~repo in + with_node repo (fun t -> Graph.v t [ ("b", `Node kn1) ]) + + let n3 ~repo = + let* kn2 = n2 ~repo in + with_node repo (fun t -> Graph.v t [ ("a", `Node kn2) ]) + + let n4 ~repo = + let* kn1 = n1 ~repo in + let* kv2 = kv2 ~repo in + let* kn4 = with_node repo (fun t -> Graph.v t [ ("x", normal kv2) ]) in + let* kn5 = + with_node repo (fun t -> Graph.v t [ ("b", `Node kn1); ("c", `Node kn4) ]) + in + with_node repo (fun t -> Graph.v t [ ("a", `Node kn5) ]) + + let r1 ~repo = + let* kn2 = n2 ~repo in + S.Tree.of_key repo (`Node kn2) >>= function + | None -> Alcotest.fail "r1" + | Some tree -> + S.Commit.v repo ~info:S.Info.empty ~parents:[] (tree :> S.tree) + + let r2 ~repo = + let* kn3 = n3 ~repo in + let* kr1 = r1 ~repo in + S.Tree.of_key repo (`Node kn3) >>= function + | None -> Alcotest.fail "r2" + | Some t3 -> + S.Commit.v repo ~info:S.Info.empty + ~parents:[ S.Commit.key kr1 ] + (t3 :> S.tree) + + let ignore_thunk_errors f = Lwt.catch f (fun _ -> Lwt.return_unit) + + let run (x : Suite.t) test = + let repo_ptr = ref None in + let config_ptr = ref None in + Lwt.catch + (fun () -> + let module Conf = Irmin.Backend.Conf in + let generate_random_root config = + let id = Random.int 100 |> string_of_int in + let root_value = + match Conf.find_root config with + | None -> "test_" ^ id + | Some v -> v ^ "_" ^ id + in + let root_key = Conf.(root (spec config)) in + Conf.add config root_key root_value + in + let config = generate_random_root x.config in + config_ptr := Some config; + let* () = x.init ~config in + let* repo = S.Repo.v config in + repo_ptr := Some repo; + let* () = test repo in + let* () = + (* [test] might have already closed the repo. That + [ignore_thunk_errors] shall be removed as soon as all stores + support double closes. *) + ignore_thunk_errors (fun () -> S.Repo.close repo) + in + x.clean ~config) + (fun exn -> + (* [test] failed, attempt an errorless cleanup and forward the right + backtrace to the user. *) + let bt = Printexc.get_raw_backtrace () in + let* () = + match !repo_ptr with + | Some repo -> ignore_thunk_errors (fun () -> S.Repo.close repo) + | None -> Lwt.return_unit + in + let+ () = + match !config_ptr with + | Some config -> ignore_thunk_errors (fun () -> x.clean ~config) + | None -> Lwt.return_unit + in + Printexc.raise_with_backtrace exn bt) +end + +let filter_src src = + not + (List.mem ~equal:String.equal (Logs.Src.name src) + [ + "git.inflater.decoder"; + "git.deflater.encoder"; + "git.encoder"; + "git.decoder"; + "git.loose"; + "git.store"; + "cohttp.lwt.io"; + ]) + +let reporter ?prefix () = + Irmin.Export_for_backends.Logging.reporter ~filter_src ?prefix + (module Mtime_clock) + +let () = + Logs.set_level (Some Logs.Debug); + Logs.set_reporter (reporter ()) + +let line ppf ?color c = + let line = String.v ~len:80 (fun _ -> c) in + match color with + | Some c -> Fmt.pf ppf "%a\n%!" Fmt.(styled c string) line + | None -> Fmt.pf ppf "%s\n%!" line + +let line msg = + let line () = line Fmt.stderr ~color:`Yellow '-' in + line (); + [%logs.info "ASSERT %s" msg]; + line () + +let ( / ) = Filename.concat + +let testable t = + Alcotest.testable (Irmin.Type.pp_dump t) Irmin.Type.(unstage (equal t)) + +let check t = Alcotest.check (testable t) + +let slist (type a) (a : a Alcotest.testable) compare = + let l = Alcotest.list a in + let eq l1 l2 = + Alcotest.equal l (List.sort compare l1) (List.sort compare l2) + in + Alcotest.testable (Alcotest.pp l) eq + +let checks t = + let t = slist (testable t) Irmin.Type.(unstage (compare t)) in + Alcotest.check t + +(* also in test/irmin-pack/common.ml *) +let check_raises_lwt msg exn (type a) (f : unit -> a Lwt.t) = + Lwt.catch + (fun x -> + let* (_ : a) = f x in + Alcotest.failf + "Fail %s: expected function to raise %s, but it returned instead." msg + (Printexc.to_string exn)) + (function + | e when e = exn -> Lwt.return_unit + | e -> + Alcotest.failf + "Fail %s: expected function to raise %s, but it raised %s instead." + msg (Printexc.to_string exn) (Printexc.to_string e)) + +module T = Irmin.Type + +module type Sleep = sig + val sleep : float -> unit Lwt.t +end diff --git a/irmin/test/helpers/helpers.ml b/irmin/test/helpers/helpers.ml new file mode 100644 index 000000000000..c2593ec7a605 --- /dev/null +++ b/irmin/test/helpers/helpers.ml @@ -0,0 +1,19 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let init_logs () = + Logs.set_level (Some Debug); + Logs.set_reporter (Common.reporter ()) diff --git a/irmin/test/helpers/import.ml b/irmin/test/helpers/import.ml new file mode 100644 index 000000000000..71053e21ba54 --- /dev/null +++ b/irmin/test/helpers/import.ml @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2021 Craig Ferguson + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin.Export_for_backends diff --git a/irmin/test/helpers/irmin_test.ml b/irmin/test/helpers/irmin_test.ml new file mode 100644 index 000000000000..cac12cf3c4db --- /dev/null +++ b/irmin/test/helpers/irmin_test.ml @@ -0,0 +1,20 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Common +module Store = Store +module Common = Common +module Node = Node diff --git a/irmin/test/helpers/irmin_test.mli b/irmin/test/helpers/irmin_test.mli new file mode 100644 index 000000000000..52fa646d486b --- /dev/null +++ b/irmin/test/helpers/irmin_test.mli @@ -0,0 +1,74 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = Common.S +module type Generic_key = Common.Generic_key + +val reporter : ?prefix:string -> unit -> Logs.reporter + +module Suite : sig + type t + + val create : + name:string -> + ?init:(config:Irmin.config -> unit Lwt.t) -> + ?clean:(config:Irmin.config -> unit Lwt.t) -> + config:Irmin.config -> + store:(module S) -> + ?stats:(unit -> int * int) -> + ?import_supported:bool -> + unit -> + t + + val create_generic_key : + name:string -> + ?init:(config:Irmin.config -> unit Lwt.t) -> + ?clean:(config:Irmin.config -> unit Lwt.t) -> + config:Irmin.config -> + store:(module Generic_key) -> + ?stats:(unit -> int * int) -> + ?import_supported:bool -> + unit -> + t + + val name : t -> string + val config : t -> Irmin.config + val store : t -> (module S) option + val init : t -> config:Irmin.config -> unit Lwt.t + val clean : t -> config:Irmin.config -> unit Lwt.t +end + +val line : string -> unit + +module Schema = Common.Schema + +val store : (module Irmin.Maker) -> (module Irmin.Metadata.S) -> (module S) +val testable : 'a Irmin.Type.t -> 'a Alcotest.testable +val check : 'a Irmin.Type.t -> string -> 'a -> 'a -> unit +val checks : 'a Irmin.Type.t -> string -> 'a list -> 'a list -> unit + +module Store : sig + val run : + string -> + ?slow:bool -> + ?random_seed:int -> + sleep:(float -> unit Lwt.t) -> + misc:unit Alcotest_lwt.test list -> + (Alcotest.speed_level * Suite.t) list -> + unit Lwt.t +end + +module Node = Node diff --git a/irmin/test/helpers/node.ml b/irmin/test/helpers/node.ml new file mode 100644 index 000000000000..c653418a223d --- /dev/null +++ b/irmin/test/helpers/node.ml @@ -0,0 +1,150 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let check _pos typ ~expected actual = + let typ = + Alcotest.testable Irmin.Type.(pp_dump typ) Irmin.Type.(unstage (equal typ)) + in + Alcotest.check typ "" expected actual + +module type Map = sig + type t [@@deriving irmin] + type data [@@deriving irmin] + type key := string + + val empty : unit -> t + val is_empty : t -> bool + val length : t -> int + val list : ?offset:int -> ?length:int -> ?cache:bool -> t -> (key * data) list + val find : ?cache:bool -> t -> key -> data option + val add : t -> key -> data -> t + val remove : t -> key -> t + + (* Generators for use by the tests: *) + val random_data : unit -> data +end + +module Suite (Map : Map) = struct + type key = string [@@deriving irmin] + + let random_bindings n = + List.init n (fun i -> (string_of_int i, Map.random_data ())) + + let map_of_bindings kvs = + List.fold_left (fun t (k, v) -> Map.add t k v) (Map.empty ()) kvs + + let test_empty () = + check __POS__ [%typ: bool] ~expected:true Map.(is_empty (empty ())); + check __POS__ [%typ: int] ~expected:0 Map.(length (empty ())); + check __POS__ [%typ: (key * Map.data) list] ~expected:[] + Map.(list (empty ())) + + let test_add () = + let with_binding k v t = Map.add t k v in + let d1 = Map.random_data () and d2 = Map.random_data () in + let a = Map.empty () |> with_binding "1" d1 |> with_binding "2" d2 in + check __POS__ [%typ: int] ~expected:2 (Map.length a) + + let test_remove () = + (* Remove is a no-op on an empty node *) + check __POS__ [%typ: Map.t] ~expected:(Map.empty ()) + Map.(remove (empty ()) "foo") + + let test_find () = + let bindings = random_bindings 256 in + let node = map_of_bindings bindings in + bindings + |> List.iter (fun (k, v) -> + check __POS__ [%typ: Map.data option] ~expected:(Some v) + (Map.find node k)) + + let test_equal () = + let module Map = struct + include Map + + type nonrec t = t [@@deriving irmin ~equal ~to_bin_string ~of_bin_string] + end in + let bindings = random_bindings 256 in + let m = map_of_bindings bindings in + + let m_rev = map_of_bindings (List.rev bindings) in + check __POS__ [%typ: bool] ~expected:true (Map.equal m m_rev); + + let m_subset = map_of_bindings (List.tl bindings) in + check __POS__ [%typ: bool] ~expected:false (Map.equal m m_subset); + + let m_serialised = + m |> Map.to_bin_string |> Map.of_bin_string |> Result.get_ok + in + check __POS__ [%typ: bool] ~expected:true (Map.equal m m_serialised) + + let suite = + [ + ("empty", test_empty); + ("add", test_add); + ("remove", test_remove); + ("find", test_find); + ("equal", test_equal); + ] +end + +module Make (Make_node : Irmin.Node.Generic_key.Maker) : sig + val suite : unit Alcotest.test_case list +end = struct + (* For each [Node] maker, we can instantiate the test suite above twice: once + for regular nodes, and once for portable nodes. *) + + module Schema = Irmin.Schema.KV (Irmin.Contents.String) + module Hash = Schema.Hash + module Key = Irmin.Key.Of_hash (Hash) + module Node = Make_node (Hash) (Schema.Path) (Schema.Metadata) (Key) (Key) + + type key = Key.t [@@deriving irmin] + + module Extras = struct + type data = [ `Node of Key.t | `Contents of Key.t * unit ] + [@@deriving irmin] + + let random_data = + let hash_of_string = Irmin.Type.(unstage (of_bin_string Hash.t)) in + let random_string = + Irmin.Type.(unstage (random (string_of (`Fixed Hash.hash_size)))) + in + fun () -> + match hash_of_string (random_string ()) with + | Error _ -> assert false + | Ok x -> ( + match Random.int 2 with + | 0 -> `Node x + | 1 -> `Contents (x, ()) + | _ -> assert false) + end + + let suite = + let tc (name, f) = Alcotest.test_case name `Quick f in + let module Suite_node = Suite (struct + include Node + include Extras + end) in + let module Suite_node_portable = Suite (struct + include Node.Portable + include Extras + end) in + List.map tc Suite_node.suite + @ List.map + (fun (name, f) -> tc ("Portable." ^ name, f)) + Suite_node_portable.suite +end diff --git a/irmin/test/helpers/rusage.ml b/irmin/test/helpers/rusage.ml new file mode 100644 index 000000000000..98ac843ba087 --- /dev/null +++ b/irmin/test/helpers/rusage.ml @@ -0,0 +1,38 @@ +(* + * Copyright (c) 2019-2022 Zach Shipko + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +type t = { + utime : float; + stime : float; + maxrss : int64; + ixrss : int64; + idrss : int64; + isrss : int64; + minflt : int64; + majflt : int64; + nswap : int64; + inblock : int64; + oublock : int64; + msgsnd : int64; + msgrcv : int64; + nsignals : int64; + nvcsw : int64; + nivcsw : int64; +} + +type who = SELF | CHILDREN + +external get : who -> t = "unix_getrusage" diff --git a/irmin/test/helpers/rusage_stubs.c b/irmin/test/helpers/rusage_stubs.c new file mode 100644 index 000000000000..98399707271d --- /dev/null +++ b/irmin/test/helpers/rusage_stubs.c @@ -0,0 +1,57 @@ +/* Copyright (c) 2019 Zach Shipko + +Permission to use, copy, modify, and/or distribute this software for +any purpose with or without fee is hereby granted, provided that the +above copyright notice and this permission notice appear in all +copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL +WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE +AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL +DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR +PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER +TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR +PERFORMANCE OF THIS SOFTWARE. */ + +#include +#include +#include +#include + +#include +#include + +#define Nothing Val_int(0) + +CAMLprim value unix_getrusage(value v_who) { + CAMLparam1(v_who); + CAMLlocal1(v_usage); + int who = (Int_val(v_who) == 0) ? RUSAGE_SELF : RUSAGE_CHILDREN; + struct rusage ru; + if (getrusage(who, &ru)) { + caml_invalid_argument("getrusage"); + } + v_usage = caml_alloc(16, 0); + Store_field(v_usage, 0, + caml_copy_double((double)ru.ru_utime.tv_sec + + (double)ru.ru_utime.tv_usec / 1e6)); + Store_field(v_usage, 1, + caml_copy_double((double)ru.ru_stime.tv_sec + + (double)ru.ru_stime.tv_usec / 1e6)); + Store_field(v_usage, 2, caml_copy_int64(ru.ru_maxrss)); + Store_field(v_usage, 3, caml_copy_int64(ru.ru_ixrss)); + Store_field(v_usage, 4, caml_copy_int64(ru.ru_idrss)); + Store_field(v_usage, 5, caml_copy_int64(ru.ru_isrss)); + Store_field(v_usage, 6, caml_copy_int64(ru.ru_minflt)); + Store_field(v_usage, 7, caml_copy_int64(ru.ru_majflt)); + Store_field(v_usage, 8, caml_copy_int64(ru.ru_nswap)); + Store_field(v_usage, 9, caml_copy_int64(ru.ru_inblock)); + Store_field(v_usage, 10, caml_copy_int64(ru.ru_oublock)); + Store_field(v_usage, 11, caml_copy_int64(ru.ru_msgsnd)); + Store_field(v_usage, 12, caml_copy_int64(ru.ru_msgrcv)); + Store_field(v_usage, 13, caml_copy_int64(ru.ru_nsignals)); + Store_field(v_usage, 14, caml_copy_int64(ru.ru_nvcsw)); + Store_field(v_usage, 15, caml_copy_int64(ru.ru_nivcsw)); + CAMLreturn(v_usage); +} diff --git a/irmin/test/helpers/store.ml b/irmin/test/helpers/store.ml new file mode 100644 index 000000000000..44e1bc57e888 --- /dev/null +++ b/irmin/test/helpers/store.ml @@ -0,0 +1,2494 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Common + +let src = Logs.Src.create "test" ~doc:"Irmin tests" + +module Log = (val Logs.src_log src : Logs.LOG) + +module Make (S : Generic_key) = struct + include Common.Make_helpers (S) + module History = Irmin.Commit.History (B.Commit) + + let with_binding k v t = S.Tree.add t k v + let random_value value = random_string value + + let random_path ~label ~path = + let short () = random_ascii_string label in + let rec aux = function 0 -> [] | n -> short () :: aux (n - 1) in + aux path + + let random_node ~label ~path ~value = + (random_path ~label ~path, random_value value) + + let random_nodes ?(label = 8) ?(path = 5) ?(value = 1024) n = + let rec aux acc = function + | 0 -> acc + | n -> aux (random_node ~label ~path ~value :: acc) (n - 1) + in + aux [] n + + let old k () = Lwt.return_ok (Some k) + + let may repo commits = function + | None -> Lwt.return_unit + | Some f -> f repo commits + + let may_get_keys repo keys = function + | None -> Lwt.return_unit + | Some f -> + let* commits = + Lwt_list.map_p + (fun key -> + S.Commit.of_key repo key >|= function + | None -> Alcotest.fail "Cannot read commit hash" + | Some c -> c) + keys + in + f repo commits + + let may_with_branch branches repo hook = + let* heads = + Lwt_list.map_p + (fun branch -> + let+ h = S.Head.find branch in + match h with + | None -> Alcotest.fail "Cannot read head" + | Some head -> head) + branches + in + may repo heads hook + + let contents c = S.Tree.v (`Contents (c, S.Metadata.default)) + + let test_contents x () = + let test repo = + let t = B.Repo.contents_t repo in + let check_key = check B.Contents.Key.t in + let check_val = check (T.option S.contents_t) in + let* kv2 = kv2 ~repo in + let* k2' = with_contents repo (fun t -> B.Contents.add t v2) in + check_key "kv2" kv2 k2'; + let* v2' = B.Contents.find t k2' in + check_val "v2" (Some v2) v2'; + let* k2'' = with_contents repo (fun t -> B.Contents.add t v2) in + check_key "kv2" kv2 k2''; + let* kv1 = kv1 ~repo in + let* k1' = with_contents repo (fun t -> B.Contents.add t v1) in + check_key "kv1" kv1 k1'; + let* k1'' = with_contents repo (fun t -> B.Contents.add t v1) in + check_key "kv1" kv1 k1''; + let* v1' = B.Contents.find t kv1 in + check_val "v1" (Some v1) v1'; + let* v2' = B.Contents.find t kv2 in + check_val "v2" (Some v2) v2'; + B.Repo.close repo >>= fun () -> + Lwt.catch + (fun () -> + let+ _ = with_contents repo (fun t -> B.Contents.add t v2) in + Alcotest.fail "Add after close should not be allowed") + (function Irmin.Closed -> Lwt.return_unit | exn -> Lwt.fail exn) + in + run x test + + let get = function None -> Alcotest.fail "get" | Some v -> v + + let test_nodes x () = + let test repo = + let g = g repo and n = n repo in + let* k = + with_contents repo (fun c -> B.Contents.add c "foo") >|= normal + in + let check_hash = check B.Hash.t in + let check_key = check B.Node.Key.t in + let check_val = check [%typ: Graph.value option] in + let check_list = checks [%typ: S.step * B.Node.Val.value] in + let check_node msg v = + let h' = B.Node.Hash.hash v in + let+ key = with_node repo (fun n -> B.Node.add n v) in + check_hash (msg ^ ": hash(v) = add(v)") (B.Node.Key.to_hash key) h' + in + let v = B.Node.Val.empty () in + check_node "empty node" v >>= fun () -> + let v1 = B.Node.Val.add v "x" k in + check_node "node: x" v1 >>= fun () -> + let v2 = B.Node.Val.add v "x" k in + check_node "node: x (bis)" v2 >>= fun () -> + check B.Node.Val.t "add x" v1 v2; + let v0 = B.Node.Val.remove v1 "x" in + check B.Node.Val.t "remove x" v v0; + let v3 = B.Node.Val.add v1 "x" k in + Alcotest.(check bool) "same same" true (v1 == v3); + let u = B.Node.Val.add v3 "y" k in + check_node "node: x+y" v3 >>= fun () -> + let u = B.Node.Val.add u "z" k in + check_node "node: x+y+z" u >>= fun () -> + let check_values u = + check_val "find x" (Some k) (B.Node.Val.find u "x"); + check_val "find y" (Some k) (B.Node.Val.find u "y"); + check_val "find z" (Some k) (B.Node.Val.find u "x"); + check_val "find xx" None (B.Node.Val.find u "xx") + in + check_values u; + let () = + let _w = B.Node.Val.of_list [ ("y", k); ("z", k); ("x", k) ] in + (* XXX: this isn't a valid check. [u] is not concrete, and [w] is. *) + (* check B.Node.Val.t "v" u w; *) + () + in + let all = B.Node.Val.list u in + check_list "list all" [ ("x", k); ("y", k); ("z", k) ] all; + let l = B.Node.Val.list ~length:1 u in + check_list "list length=1" [ ("x", k) ] l; + let l = B.Node.Val.list ~offset:1 u in + check_list "list offset=1" [ ("y", k); ("z", k) ] l; + let l = B.Node.Val.list ~offset:1 ~length:1 u in + check_list "list offset=1 length=1" [ List.nth all 1 ] l; + let u = B.Node.Val.add u "a" k in + check_node "node: x+y+z+a" u >>= fun () -> + let u = B.Node.Val.add u "b" k in + check_node "node: x+y+z+a+b" u >>= fun () -> + let h = B.Node.Hash.hash u in + let* k = with_node repo (fun n -> B.Node.add n u) in + check_hash "hash(v) = add(v)" h (B.Node.Key.to_hash k); + let* w = B.Node.find n k in + check_values (get w); + let* kv1 = kv1 ~repo in + let* k1 = with_node repo (fun g -> Graph.v g [ ("x", normal kv1) ]) in + let* k1' = with_node repo (fun g -> Graph.v g [ ("x", normal kv1) ]) in + check_key "k1.1" k1 k1'; + let* t1 = B.Node.find n k1 in + let k' = B.Node.Val.find (get t1) "x" in + check + (Irmin.Type.option B.Node.Val.value_t) + "find x" + (Some (normal kv1)) + k'; + let* k1'' = with_node repo (fun n -> B.Node.add n (get t1)) in + check_key "k1.2" k1 k1''; + let* k2 = with_node repo (fun g -> Graph.v g [ ("b", `Node k1) ]) in + let* k2' = with_node repo (fun g -> Graph.v g [ ("b", `Node k1) ]) in + check_key "k2.1" k2 k2'; + let* t2 = B.Node.find n k2 in + let* k2'' = with_node repo (fun n -> B.Node.add n (get t2)) in + check_key "k2.2" k2 k2''; + let* k1''' = Graph.find g k2 [ "b" ] in + check_val "k1.3" (Some (`Node k1)) k1'''; + let* k3 = with_node repo (fun g -> Graph.v g [ ("a", `Node k2) ]) in + let* k3' = with_node repo (fun g -> Graph.v g [ ("a", `Node k2) ]) in + check_key "k3.1" k3 k3'; + let* t3 = B.Node.find n k3 in + let* k3'' = with_node repo (fun n -> B.Node.add n (get t3)) in + check_key "k3.2" k3 k3''; + let* k2'' = Graph.find g k3 [ "a" ] in + check_val "k2.3" (Some (`Node k2)) k2''; + let* k1'''' = Graph.find g k2' [ "b" ] in + check_val "t1.2" (Some (`Node k1)) k1''''; + let* k1''''' = Graph.find g k3 [ "a"; "b" ] in + check_val "t1.3" (Some (`Node k1)) k1'''''; + let* kv11 = Graph.find g k1 [ "x" ] in + check_val "v1.1" (Some (normal kv1)) kv11; + let* kv12 = Graph.find g k2 [ "b"; "x" ] in + check_val "v1.2" (Some (normal kv1)) kv12; + let* kv13 = Graph.find g k3 [ "a"; "b"; "x" ] in + check_val "v1" (Some (normal kv1)) kv13; + let* kv2 = kv2 ~repo in + let* k4 = with_node repo (fun g -> Graph.v g [ ("x", normal kv2) ]) in + let* k5 = + with_node repo (fun g -> Graph.v g [ ("b", `Node k1); ("c", `Node k4) ]) + in + let* k6 = with_node repo (fun g -> Graph.v g [ ("a", `Node k5) ]) in + let* k6' = + with_node repo (fun g -> Graph.add g k3 [ "a"; "c"; "x" ] (normal kv2)) + in + check_key "node k6" k6 k6'; + let* n6' = B.Node.find n k6' in + let* n6 = B.Node.find n k6 in + check T.(option B.Node.Val.t) "node n6" n6 n6'; + let assert_no_duplicates n node = + let names = ref [] in + let+ all = Graph.list g node in + List.iter + (fun (s, _) -> + if List.mem ~equal:String.equal s !names then + Alcotest.failf "%s: duplicate!" n + else names := s :: !names) + all + in + let* n0 = with_node repo (fun g -> Graph.v g []) in + let* n1 = with_node repo (fun g -> Graph.add g n0 [ "b" ] (`Node n0)) in + let* n2 = with_node repo (fun g -> Graph.add g n1 [ "a" ] (`Node n0)) in + let* n3 = with_node repo (fun g -> Graph.add g n2 [ "a" ] (`Node n0)) in + assert_no_duplicates "1" n3 >>= fun () -> + let* n1 = with_node repo (fun g -> Graph.add g n0 [ "a" ] (`Node n0)) in + let* n2 = with_node repo (fun g -> Graph.add g n1 [ "b" ] (`Node n0)) in + let* n3 = with_node repo (fun g -> Graph.add g n2 [ "a" ] (`Node n0)) in + assert_no_duplicates "2" n3 >>= fun () -> + let* n1 = with_node repo (fun g -> Graph.add g n0 [ "b" ] (normal kv1)) in + let* n2 = with_node repo (fun g -> Graph.add g n1 [ "a" ] (normal kv1)) in + let* n3 = with_node repo (fun g -> Graph.add g n2 [ "a" ] (normal kv1)) in + assert_no_duplicates "3" n3 >>= fun () -> + let* n1 = with_node repo (fun g -> Graph.add g n0 [ "a" ] (normal kv1)) in + let* n2 = with_node repo (fun g -> Graph.add g n1 [ "b" ] (normal kv1)) in + let* n3 = with_node repo (fun g -> Graph.add g n2 [ "b" ] (normal kv1)) in + assert_no_duplicates "4" n3 >>= fun () -> + S.Repo.close repo >>= fun () -> + Lwt.catch + (fun () -> + let* n0 = with_node repo (fun g -> Graph.v g []) in + let* _ = + with_node repo (fun g -> Graph.add g n0 [ "b" ] (`Node n0)) + in + Alcotest.fail "Add after close should not be allowed") + (function Irmin.Closed -> Lwt.return_unit | exn -> Lwt.fail exn) + in + run x test + + let test_commits x () = + let test repo = + let info date = + let message = Fmt.str "Test commit: %d" date in + S.Info.v ~author:"test" ~message (Int64.of_int date) + in + let* kv1 = kv1 ~repo in + let h = h repo and c = B.Repo.commit_t repo in + let check_val = check (T.option B.Commit.Val.t) in + let check_key = check B.Commit.Key.t in + let check_keys = checks B.Commit.Key.t in + (* t3 -a-> t2 -b-> t1 -x-> (v1) *) + let* kt1 = with_node repo (fun g -> Graph.v g [ ("x", normal kv1) ]) in + let* kt2 = with_node repo (fun g -> Graph.v g [ ("a", `Node kt1) ]) in + let* kt3 = with_node repo (fun g -> Graph.v g [ ("b", `Node kt2) ]) in + (* r1 : t2 *) + let with_info n fn = with_commit repo (fun h -> fn h ~info:(info n)) in + let* kr1, _ = with_info 3 (History.v ~node:kt2 ~parents:[]) in + let* kr1', _ = with_info 3 (History.v ~node:kt2 ~parents:[]) in + let* t1 = B.Commit.find c kr1 in + let* t1' = B.Commit.find c kr1' in + check_val "t1" t1 t1'; + check_key "kr1" kr1 kr1'; + + (* r1 -> r2 : t3 *) + let* kr2, _ = with_info 4 (History.v ~node:kt3 ~parents:[ kr1 ]) in + let* kr2', _ = with_info 4 (History.v ~node:kt3 ~parents:[ kr1 ]) in + check_key "kr2" kr2 kr2'; + let* kr1s = History.closure h ~min:[] ~max:[ kr1 ] in + check_keys "g1" [ kr1 ] kr1s; + let* kr2s = History.closure h ~min:[] ~max:[ kr2 ] in + check_keys "g2" [ kr1; kr2 ] kr2s; + let* () = + S.Commit.of_key repo kr1 >|= function + | None -> Alcotest.fail "Cannot read commit hash" + | Some c -> + Alcotest.(check string) + "author" "test" + (S.Info.author (S.Commit.info c)) + in + S.Repo.close repo >>= fun () -> + Lwt.catch + (fun () -> + let+ _ = with_info 3 (History.v ~node:kt1 ~parents:[]) in + Alcotest.fail "Add after close should not be allowed") + (function Irmin.Closed -> Lwt.return_unit | exn -> Lwt.fail exn) + in + run x test + + let test_closure x () = + let test repo = + let info date = + let message = Fmt.str "Test commit: %d" date in + S.Info.v ~author:"test" ~message (Int64.of_int date) + in + let check_keys = checks B.Commit.Key.t in + let equal_key = Irmin.Type.(unstage (equal B.Commit.Key.t)) in + let h = h repo in + let initialise_nodes = + Lwt_list.map_p + (fun i -> + let* kv = + with_contents repo (fun t -> B.Contents.add t (string_of_int i)) + in + with_node repo (fun g -> Graph.v g [ (string_of_int i, normal kv) ])) + [ 0; 1; 2; 3; 4; 5; 6; 7; 8 ] + in + let with_info n fn = with_commit repo (fun h -> fn h ~info:(info n)) in + let initialise_graph nodes = + match nodes with + | [] -> assert false + | node :: rest -> + let* kr0, _ = with_info 0 (History.v ~node ~parents:[]) in + let commits = Array.make 9 kr0 in + let commit ~node ~parents i = + let+ kr1, _ = with_info i (History.v ~node ~parents) in + commits.(i) <- kr1; + i + 1 + in + let+ _ = + Lwt_list.fold_left_s + (fun i node -> + match i with + | 1 -> commit ~node ~parents:[ commits.(0) ] 1 + | 2 -> commit ~node ~parents:[] 2 + | 3 -> commit ~node ~parents:[ commits.(1) ] 3 + | 4 -> commit ~node ~parents:[ commits.(1); commits.(2) ] 4 + | 5 -> commit ~node ~parents:[ commits.(3); commits.(4) ] 5 + | 6 -> commit ~node ~parents:[ commits.(4) ] 6 + | 7 -> commit ~node ~parents:[] 7 + | 8 -> commit ~node ~parents:[ commits.(7) ] 8 + | _ -> assert false) + 1 rest + in + commits + in + (* initialise_graph creates the following graph of commits: + 0 <- 1 <- 3 <- 5 and 7 <- 8 + \ / + 2 <-- 4 <- 6 *) + let* commits = initialise_nodes >>= initialise_graph in + let* krs = History.closure h ~min:[ commits.(1) ] ~max:[ commits.(5) ] in + check_keys "commits between 1 and 5" + [ commits.(1); commits.(2); commits.(3); commits.(4); commits.(5) ] + krs; + let* krs = History.closure h ~min:[] ~max:[ commits.(5) ] in + check_keys "all commits under 5" + [ + commits.(0); + commits.(1); + commits.(2); + commits.(3); + commits.(4); + commits.(5); + ] + krs; + let* krs = + History.closure h + ~min:[ commits.(1); commits.(2) ] + ~max:[ commits.(5); commits.(6) ] + in + check_keys "disconnected max and min returns a connected graph" + [ + commits.(1); + commits.(2); + commits.(3); + commits.(4); + commits.(5); + commits.(6); + ] + krs; + let* krs = + History.closure h + ~min:[ commits.(1); commits.(7) ] + ~max:[ commits.(4); commits.(8) ] + in + check_keys "disconnected min and max returns a disconnected graph" + [ commits.(1); commits.(2); commits.(7); commits.(4); commits.(8) ] + krs; + let* () = + History.closure h ~min:[ commits.(7) ] ~max:[] >|= function + | [] -> () + | _ -> Alcotest.fail "expected empty list" + in + let* () = + let+ ls = History.closure h ~min:[ commits.(7) ] ~max:[ commits.(6) ] in + if List.mem ~equal:equal_key commits.(7) ls then + Alcotest.fail "disconnected node should not be in closure" + in + let* krs = + History.closure h ~min:[ commits.(4) ] ~max:[ commits.(4); commits.(6) ] + in + check_keys "min and max have the same commit" + [ commits.(6); commits.(4) ] + krs; + let* () = + let+ ls = + History.closure h + ~min:[ commits.(4); commits.(0) ] + ~max:[ commits.(4); commits.(6) ] + in + if List.mem ~equal:equal_key commits.(0) ls then + Alcotest.fail "disconnected node should not be in closure" + in + S.Repo.close repo + in + run x test + + let test_branches ?hook x () = + let test repo = + let check_keys = checks S.Branch.t in + let check_val = check (T.option @@ S.commit_t repo) in + let* kv1 = r1 ~repo in + let* kv2 = r2 ~repo in + line "pre-update"; + S.Branch.set repo b1 kv1 >>= fun () -> + may repo [ kv2 ] hook >>= fun () -> + line "post-update"; + let* k1' = S.Branch.find repo b1 in + check_val "r1" (Some kv1) k1'; + S.Branch.set repo b2 kv2 >>= fun () -> + let* k2' = S.Branch.find repo b2 in + check_val "r2" (Some kv2) k2'; + S.Branch.set repo b1 kv2 >>= fun () -> + let* k2'' = S.Branch.find repo b1 in + check_val "r1-after-update" (Some kv2) k2''; + let* bs = S.Branch.list repo in + check_keys "list" [ b1; b2 ] bs; + S.Branch.remove repo b1 >>= fun () -> + let* empty = S.Branch.find repo b1 in + check_val "empty" None empty; + let* b2' = S.Branch.list repo in + check_keys "all-after-remove" [ b2 ] b2'; + S.Repo.close repo >>= fun () -> + Lwt.catch + (fun () -> + let+ _ = S.Branch.set repo b1 kv1 in + Alcotest.fail "Add after close should not be allowed") + (function Irmin.Closed -> Lwt.return_unit | exn -> Lwt.fail exn) + in + run x test + + let test_tree_hashes x () = + let test repo = + let node bindings = + with_node repo (fun g -> + let* empty = Graph.empty g in + Lwt_list.fold_left_s + (fun t (k, v) -> + let* v = with_contents repo (fun t -> B.Contents.add t v) in + Graph.add g t k (`Contents (v, S.Metadata.default))) + empty bindings) + in + let tree bindings = + Lwt_list.fold_left_s + (fun t (k, v) -> S.Tree.add t k v) + (S.Tree.empty ()) bindings + in + let check_hash msg bindings = + let* node = node bindings in + let+ tree = tree bindings in + check B.Hash.t msg (B.Node.Key.to_hash node) (S.Tree.hash tree) + in + check_hash "empty" [] >>= fun () -> + let bindings1 = [ ([ "a" ], "x"); ([ "b" ], "y") ] in + check_hash "1 level" bindings1 >>= fun () -> + let bindings2 = [ ([ "a"; "b" ], "x"); ([ "a"; "c" ], "y") ] in + check_hash "2 levels" bindings2 >>= fun () -> S.Repo.close repo + in + run x test + + let test_simple_merges ?hook x () = + (* simple merges *) + let check_merge () = + let ok = Irmin.Merge.ok in + let dt = [%typ: int64 option] in + let dx = [%typ: (string * int64) list] in + let merge_skip ~old:_ _ _ = ok None in + let merge_left ~old:_ x _ = ok x in + let merge_right ~old:_ _ y = ok y in + let merge_default = Irmin.Merge.default dt in + let merge = function + | "left" -> Irmin.Merge.v dt merge_left + | "right" -> Irmin.Merge.v dt merge_right + | "skip" -> Irmin.Merge.v dt merge_skip + | _ -> merge_default + in + let merge_x = Irmin.Merge.alist T.string T.int64 merge in + let old () = ok (Some [ ("left", 1L); ("foo", 2L) ]) in + let x = [ ("left", 2L); ("right", 0L) ] in + let y = [ ("left", 1L); ("bar", 3L); ("skip", 0L) ] in + let m = [ ("left", 2L); ("bar", 3L) ] in + Irmin.Merge.(f merge_x) ~old x y >>= function + | Error (`Conflict c) -> Alcotest.failf "conflict %s" c + | Ok m' -> + check dx "compound merge" m m'; + Lwt.return_unit + in + let test repo = + check_merge () >>= fun () -> + let* kv1 = kv1 ~repo in + let* kv2 = kv2 ~repo in + let result = + T.(result (option B.Contents.Key.t) Irmin.Merge.conflict_t) + in + (* merge contents *) + let* kv1' = + with_contents repo (fun v -> + Irmin.Merge.f (B.Contents.merge v) ~old:(old (Some kv1)) (Some kv1) + (Some kv1)) + in + check result "merge kv1" (Ok (Some kv1)) kv1'; + let* kv2' = + with_contents repo (fun v -> + Irmin.Merge.f (B.Contents.merge v) ~old:(old (Some kv1)) (Some kv1) + (Some kv2)) + in + check result "merge kv2" (Ok (Some kv2)) kv2'; + + (* merge nodes *) + let g = g repo in + (* The empty node *) + let* k0 = with_node repo (fun g -> Graph.v g []) in + (* Create the node t1 -x-> (v1) *) + let* k1 = with_node repo (fun g -> Graph.v g [ ("x", normal kv1) ]) in + (* Create the node t2 -b-> t1 -x-> (v1) *) + let* k2 = with_node repo (fun g -> Graph.v g [ ("b", `Node k1) ]) in + (* Create the node t3 -c-> t1 -x-> (v1) *) + let* k3 = with_node repo (fun g -> Graph.v g [ ("c", `Node k1) ]) in + (* Should create the node: + t4 -b-> t1 -x-> (v1) + \c/ *) + let* k4 = + with_node repo (fun g -> + Irmin.Merge.(f @@ B.Node.merge g) + ~old:(old (Some k0)) (Some k2) (Some k3)) + in + let* k4 = merge_exn "k4" k4 in + let k4 = match k4 with Some k -> k | None -> failwith "k4" in + let _ = k4 in + let succ_t = [%typ: string * Graph.value] in + let* succ = Graph.list g k4 in + checks succ_t "k4" [ ("b", `Node k1); ("c", `Node k1) ] succ; + let info date = + let i = Int64.of_int date in + S.Info.v ~author:"test" ~message:"Test commit" i + in + let c = B.Repo.commit_t repo in + let with_info n fn = with_commit repo (fun h -> fn h ~info:(info n)) in + let* kr0, _ = with_info 0 (History.v ~node:k0 ~parents:[]) in + let* kr1, _ = with_info 1 (History.v ~node:k2 ~parents:[ kr0 ]) in + let* kr2, _ = with_info 2 (History.v ~node:k3 ~parents:[ kr0 ]) in + may_get_keys repo [ kr1; kr2 ] hook >>= fun () -> + let* kr3 = + with_info 3 (fun h ~info -> + Irmin.Merge.f + (History.merge h ~info:(fun () -> info)) + ~old:(old kr0) kr1 kr2) + in + let* kr3 = merge_exn "kr3" kr3 in + may_get_keys repo [ kr3 ] hook >>= fun () -> + let* kr3_key' = + with_info 4 (fun h ~info -> + Irmin.Merge.f + (History.merge h ~info:(fun () -> info)) + ~old:(old kr2) kr2 kr3) + in + let* kr3_key' = merge_exn "kr3_key'" kr3_key' in + let check_key = check B.Commit.Key.t in + check_key "kr3 id with immediate parent'" kr3 kr3_key'; + let* kr3_key = + with_info 5 (fun h ~info -> + Irmin.Merge.f + (History.merge h ~info:(fun () -> info)) + ~old:(old kr0) kr0 kr3) + in + let* kr3_key = merge_exn "kr3_key" kr3_key in + check_key "kr3 key with old parent" kr3 kr3_key; + let* kr3', _ = with_info 3 @@ History.v ~node:k4 ~parents:[ kr1; kr2 ] in + let* r3 = B.Commit.find c kr3 in + let* r3' = B.Commit.find c kr3' in + check T.(option B.Commit.Val.t) "r3" r3 r3'; + check_key "kr3" kr3 kr3'; + B.Repo.close repo + in + run x test + + let test_history ?hook x () = + let test repo = + let info date = + let i = Int64.of_int date in + S.Info.v ~author:"test" ~message:"Test commit" i + in + let assert_lcas_err msg err l2 = + let err_str = function + | `Too_many_lcas -> "Too_many_lcas" + | `Max_depth_reached -> "Max_depth_reached" + in + let pp_commits = Fmt.Dump.(list S.Commit.pp_hash) in + let l2 = + match l2 with + | Ok x -> Alcotest.failf "%s: %a" msg pp_commits x + | Error e -> err_str e + in + Alcotest.(check string) msg (err_str err) l2 + in + let assert_lcas msg l1 l2 = + let l2 = + match l2 with + | Ok x -> x + | Error `Too_many_lcas -> Alcotest.failf "%s: Too many LCAs" msg + | Error `Max_depth_reached -> + Alcotest.failf "%s: max depth reached" msg + in + checks (S.commit_t repo) msg l1 l2 + in + let assert_lcas msg ~max_depth n a b expected = + let* a = S.of_commit a in + let* b = S.of_commit b in + let* lcas = S.lcas ~max_depth ~n a b in + assert_lcas msg expected lcas; + let* lcas = S.lcas ~max_depth:(max_depth - 1) ~n a b in + let msg = Printf.sprintf "%s [max-depth=%d]" msg (max_depth - 1) in + assert_lcas_err msg `Max_depth_reached lcas; + Lwt.return_unit + in + let assert_last_modified msg ?depth ~n t key expected = + let+ last = S.last_modified ?depth ~n t key in + S.repo t |> fun repo -> + let msg = Printf.sprintf "%s [n=%d]" msg n in + checks (S.commit_t repo) msg expected last + in + let assert_history_empty msg c expected = + let* t = S.of_commit c in + S.history t + >|= S.History.is_empty + >|= Alcotest.(check bool) msg expected + in + let tree = S.Tree.empty () in + let k0 = random_path ~label:8 ~path:5 in + let k1 = random_path ~label:8 ~path:4 in + let k2 = random_path ~label:8 ~path:6 in + + (* test that we don't compute too many lcas + + 0(k0, k1) -> 1(k1) -> 2(k0) -> 3(k1, k0) -> 4(k1) + *) + let* tree = S.Tree.add tree k0 (random_value 1024) in + let* tree = S.Tree.add tree k1 (random_value 1024) in + let* c0 = S.Commit.v repo ~info:(info 0) ~parents:[] tree in + may repo [ c0 ] hook >>= fun () -> + assert_history_empty "nonempty 1 commit" c0 false >>= fun () -> + let* tree = S.Tree.add tree k1 (random_value 1024) in + let* c1 = + S.Commit.v repo ~info:(info 1) ~parents:[ S.Commit.key c0 ] tree + in + assert_history_empty "nonempty 2 commits" c0 false >>= fun () -> + let* tree = S.Tree.add tree k0 (random_value 1024) in + let* c2 = + S.Commit.v repo ~info:(info 2) ~parents:[ S.Commit.key c1 ] tree + in + let* tree = S.Tree.add tree k0 (random_value 1024) in + let* tree = S.Tree.add tree k1 (random_value 1024) in + let* c3 = + S.Commit.v repo ~info:(info 3) ~parents:[ S.Commit.key c2 ] tree + in + may repo [ c3 ] hook >>= fun () -> + let* tree = S.Tree.add tree k1 (random_value 1024) in + let* c4 = + S.Commit.v repo ~info:(info 4) ~parents:[ S.Commit.key c3 ] tree + in + assert_lcas "line lcas 1" ~max_depth:0 3 c3 c4 [ c3 ] >>= fun () -> + assert_lcas "line lcas 2" ~max_depth:1 3 c2 c4 [ c2 ] >>= fun () -> + assert_lcas "line lcas 3" ~max_depth:2 3 c1 c4 [ c1 ] >>= fun () -> + let* store = S.of_commit c4 in + let* () = + assert_last_modified "line last_modified 1" ~n:1 store k0 [ c3 ] + in + let* () = + assert_last_modified "line last_modified 2" ~n:2 store k0 [ c2; c3 ] + in + let* () = + assert_last_modified "line last_modified 3" ~n:3 store k0 [ c0; c2; c3 ] + in + let* () = + assert_last_modified "line last_modified 4" ~depth:1 ~n:3 store k0 + [ c3 ] + in + assert_last_modified "line last_modified 5" ~n:1 store k2 [] >>= fun () -> + let* () = + assert_last_modified "line last_modified 5" ~depth:0 ~n:2 store k0 [] + in + (* test for multiple lca + + 4(k1) -> 10 (k2) ---> 11(k0, k2) --> 13(k1) --> 15(k1, k2) + | \_______________________/____ + | _____________________/ \ + | / \ + \---> 12 (k0, k1) --> 14 (k2) --> 16 (k2) --> 17 (k0) + *) + let* tree = S.Tree.add tree k2 (random_value 1024) in + let* c10 = + S.Commit.v repo ~info:(info 10) ~parents:[ S.Commit.key c4 ] tree + in + let* tree_up = S.Tree.add tree k0 (random_value 1024) in + let* tree_up = S.Tree.add tree_up k2 (random_value 1024) in + let* c11 = + S.Commit.v repo ~info:(info 11) ~parents:[ S.Commit.key c10 ] tree_up + in + let* tree_down = S.Tree.add tree k0 (random_value 1024) in + let* tree_12 = S.Tree.add tree_down k1 (random_value 1024) in + let* c12 = + S.Commit.v repo ~info:(info 12) ~parents:[ S.Commit.key c10 ] tree_12 + in + let* tree_up = S.Tree.add tree_up k1 (random_value 1024) in + let* c13 = + S.Commit.v repo ~info:(info 13) ~parents:[ S.Commit.key c11 ] tree_up + in + let* tree_down = S.Tree.add tree_12 k2 (random_value 1024) in + let* c14 = + S.Commit.v repo ~info:(info 14) ~parents:[ S.Commit.key c12 ] tree_down + in + let* tree_up = S.Tree.add tree_12 k1 (random_value 1024) in + let* tree_up = S.Tree.add tree_up k2 (random_value 1024) in + let* c15 = + S.Commit.v repo ~info:(info 15) + ~parents:[ S.Commit.key c12; S.Commit.key c13 ] + tree_up + in + let* tree_down = S.Tree.add tree_down k2 (random_value 1024) in + let* c16 = + S.Commit.v repo ~info:(info 16) ~parents:[ S.Commit.key c14 ] tree_down + in + let* tree_down = S.Tree.add tree_down k0 (random_value 1024) in + let* c17 = + S.Commit.v repo ~info:(info 17) + ~parents:[ S.Commit.key c11; S.Commit.key c16 ] + tree_down + in + assert_lcas "x lcas 0" ~max_depth:0 5 c10 c10 [ c10 ] >>= fun () -> + assert_lcas "x lcas 1" ~max_depth:0 5 c14 c14 [ c14 ] >>= fun () -> + assert_lcas "x lcas 2" ~max_depth:0 5 c10 c11 [ c10 ] >>= fun () -> + assert_lcas "x lcas 3" ~max_depth:1 5 c12 c16 [ c12 ] >>= fun () -> + assert_lcas "x lcas 4" ~max_depth:1 5 c10 c13 [ c10 ] >>= fun () -> + assert_lcas "x lcas 5" ~max_depth:2 5 c13 c14 [ c10 ] >>= fun () -> + assert_lcas "x lcas 6" ~max_depth:3 5 c15 c16 [ c12 ] >>= fun () -> + assert_lcas "x lcas 7" ~max_depth:3 5 c15 c17 [ c11; c12 ] >>= fun () -> + let* store = S.of_commit c17 in + let* () = + assert_last_modified "x last_modified 1" ~n:3 store k0 [ c11; c12; c17 ] + in + let* () = + assert_last_modified "x last_modified 2" ~n:1 store k2 [ c16 ] + in + let* () = + assert_last_modified "x last_modified 3" ~n:2 store k1 [ c4; c12 ] + in + let* () = + assert_last_modified "x last_modified 4" ~depth:3 ~n:5 store k1 + [ c4; c12 ] + in + let* () = + assert_last_modified "x last_modified 5" ~depth:2 ~n:3 store k0 + [ c11; c17 ] + in + (* lcas on non transitive reduced graphs + + /->16 + | + 4->10->11->12->13->14->15 + | \--|--/ + \-----------/ + *) + let* c10 = + S.Commit.v repo ~info:(info 10) ~parents:[ S.Commit.key c4 ] tree + in + let* c11 = + S.Commit.v repo ~info:(info 11) ~parents:[ S.Commit.key c10 ] tree + in + let* c12 = + S.Commit.v repo ~info:(info 12) ~parents:[ S.Commit.key c11 ] tree + in + let* c13 = + S.Commit.v repo ~info:(info 13) ~parents:[ S.Commit.key c12 ] tree + in + let* c14 = + S.Commit.v repo ~info:(info 14) + ~parents:[ S.Commit.key c11; S.Commit.key c13 ] + tree + in + let* c15 = + S.Commit.v repo ~info:(info 15) + ~parents:[ S.Commit.key c13; S.Commit.key c14 ] + tree + in + let* c16 = + S.Commit.v repo ~info:(info 16) ~parents:[ S.Commit.key c11 ] tree + in + assert_lcas "weird lcas 1" ~max_depth:0 3 c14 c15 [ c14 ] >>= fun () -> + assert_lcas "weird lcas 2" ~max_depth:0 3 c13 c15 [ c13 ] >>= fun () -> + assert_lcas "weird lcas 3" ~max_depth:1 3 c12 c15 [ c12 ] >>= fun () -> + assert_lcas "weird lcas 4" ~max_depth:1 3 c11 c15 [ c11 ] >>= fun () -> + assert_lcas "weird lcas 4" ~max_depth:3 3 c15 c16 [ c11 ] >>= fun () -> + (* fast-forward *) + let ff = testable Irmin.Type.(result unit S.ff_error_t) in + let* t12 = S.of_commit c12 in + let* b1 = S.Head.fast_forward t12 c16 in + Alcotest.(check ff) "ff 1.1" (Error `Rejected) b1; + let* k12' = S.Head.get t12 in + check (S.commit_t repo) "ff 1.2" c12 k12'; + let* b2 = S.Head.fast_forward t12 ~n:1 c14 in + Alcotest.(check ff) "ff 2.1" (Error `Rejected) b2; + let* k12'' = S.Head.get t12 in + check (S.commit_t repo) "ff 2.2" c12 k12''; + let* b3 = S.Head.fast_forward t12 c14 in + Alcotest.(check ff) "ff 2.2" (Ok ()) b3; + let* c14' = S.Head.get t12 in + check (S.commit_t repo) "ff 2.3" c14 c14'; + B.Repo.close repo + in + run x test + + let test_empty ?hook x () = + let test repo = + let* t = S.empty repo in + let* h = S.Head.find t in + check T.(option @@ S.commit_t repo) "empty" None h; + let* r1 = r1 ~repo in + may repo [ r1 ] hook >>= fun () -> + S.set_exn t ~info:S.Info.none [ "b"; "x" ] v1 >>= fun () -> + let* h = S.Head.find t in + check T.(option @@ S.commit_t repo) "not empty" (Some r1) h; + B.Repo.close repo + in + run x test + + let test_slice ?hook x () = + let test repo = + let* t = S.main repo in + let a = "" in + let b = "haha" in + S.set_exn t ~info:(infof "slice") [ "x"; "a" ] a >>= fun () -> + S.set_exn t ~info:(infof "slice") [ "x"; "b" ] b >>= fun () -> + may_with_branch [ t ] repo hook >>= fun () -> + let* slice = S.Repo.export repo in + let str = T.to_json_string B.Slice.t slice in + let slice' = + match T.decode_json B.Slice.t (Jsonm.decoder (`String str)) with + | Ok t -> t + | Error (`Msg e) -> Alcotest.failf "decoding error: %s" e + in + check B.Slice.t "slices" slice slice'; + B.Repo.close repo + in + run x test + + let test_backend_nodes ?hook x () = + let test repo = + let check_val = check [%typ: S.contents option] in + let vx = "VX" in + let vy = "VY" in + let* t = S.main repo in + S.set_exn t ~info:(infof "add x/y/z") [ "x"; "y"; "z" ] vx >>= fun () -> + let* tree = S.get_tree t [ "x" ] in + S.set_tree_exn t ~info:(infof "update") [ "u" ] tree >>= fun () -> + let* vx' = S.find t [ "u"; "y"; "z" ] in + check_val "vx" (Some vx) vx'; + let* tree1 = S.get_tree t [ "u" ] in + S.set_exn t ~info:(infof "add u/x/y") [ "u"; "x"; "y" ] vy >>= fun () -> + may_with_branch [ t ] repo hook >>= fun () -> + let* tree2 = S.get_tree t [ "u" ] in + let* tree3 = S.Tree.add tree [ "x"; "z" ] vx in + let* v' = + Irmin.Merge.f S.Tree.merge ~old:(Irmin.Merge.promise tree1) tree2 tree3 + >>= merge_exn "tree" + in + S.set_tree_exn t ~info:(infof "merge") [ "u" ] v' >>= fun () -> + let* vy' = S.find t [ "u"; "x"; "y" ] in + check_val "vy after merge" (Some vy) vy'; + let* vx' = S.find t [ "u"; "x"; "z" ] in + check_val "vx after merge" (Some vx) vx'; + B.Repo.close repo + in + run x test + + let test_stores x () = + let test repo = + let check_val = check [%typ: S.contents option] in + let check_list = checks [%typ: S.Path.step * S.tree] in + let* t = S.main repo in + S.set_exn t ~info:(infof "init") [ "a"; "b" ] v1 >>= fun () -> + let* b0 = S.mem t [ "a"; "b" ] in + Alcotest.(check bool) "mem0" true b0; + let* t = S.clone ~src:t ~dst:"test" in + let* b1 = S.mem t [ "a"; "b" ] in + Alcotest.(check bool) "mem1" true b1; + let* b2 = S.mem t [ "a" ] in + Alcotest.(check bool) "mem2" false b2; + let* v1' = S.find t [ "a"; "b" ] in + check_val "v1.1" (Some v1) v1'; + let* r1 = S.Head.get t in + let* t = S.clone ~src:t ~dst:"test" in + S.set_exn t ~info:(infof "update") [ "a"; "c" ] v2 >>= fun () -> + let* b1 = S.mem t [ "a"; "b" ] in + Alcotest.(check bool) "mem3" true b1; + let* b2 = S.mem t [ "a" ] in + Alcotest.(check bool) "mem4" false b2; + let* v1' = S.find t [ "a"; "b" ] in + check_val "v1.1" (Some v1) v1'; + let* b1 = S.mem t [ "a"; "c" ] in + Alcotest.(check bool) "mem5" true b1; + let* v2' = S.find t [ "a"; "c" ] in + check_val "v1.1" (Some v2) v2'; + S.remove_exn t ~info:(infof "remove") [ "a"; "b" ] >>= fun () -> + let* v1'' = S.find t [ "a"; "b" ] in + check_val "v1.2" None v1''; + S.Head.set t r1 >>= fun () -> + let* v1'' = S.find t [ "a"; "b" ] in + check_val "v1.3" (Some v1) v1''; + let* ks = S.list t [ "a" ] in + check_list "path" [ ("b", contents v1) ] ks; + let* () = + S.set_exn t ~info:(infof "update2") [ "a"; long_random_ascii_string ] v1 + in + S.remove_exn t ~info:(infof "remove rec") [ "a" ] >>= fun () -> + let* dirs = S.list t [] in + check_list "remove rec" [] dirs; + let* () = + Lwt.catch + (fun () -> + S.set_exn t ~info:(infof "update root") [] v1 >>= fun () -> + Alcotest.fail "update root") + (function + | Invalid_argument _ -> Lwt.return_unit + | e -> Alcotest.fail ("update root: " ^ Printexc.to_string e)) + in + let* none = S.find t [] in + check_val "read root" none None; + S.set_exn t ~info:(infof "update") [ "a" ] v1 >>= fun () -> + S.remove_exn t ~info:(infof "remove rec --all") [] >>= fun () -> + let* dirs = S.list t [] in + check_list "remove rec root" [] dirs; + let a = "ok" in + let b = "maybe?" in + S.set_exn t ~info:(infof "fst one") [ "fst" ] a >>= fun () -> + S.set_exn t ~info:(infof "snd one") [ "fst"; "snd" ] b >>= fun () -> + let* fst = S.find t [ "fst" ] in + check_val "data model 1" None fst; + let* snd = S.find t [ "fst"; "snd" ] in + check_val "data model 2" (Some b) snd; + S.set_exn t ~info:(infof "fst one") [ "fst" ] a >>= fun () -> + let* fst = S.find t [ "fst" ] in + check_val "data model 3" (Some a) fst; + let* snd = S.find t [ "fst"; "snd" ] in + check_val "data model 4" None snd; + let tagx = "x" in + let tagy = "y" in + let xy = [ "x"; "y" ] in + let vx = "VX" in + let* tx = S.of_branch repo tagx in + S.Branch.remove repo tagx >>= fun () -> + S.Branch.remove repo tagy >>= fun () -> + S.set_exn tx ~info:(infof "update") xy vx >>= fun () -> + let* ty = S.clone ~src:tx ~dst:tagy in + let* vx' = S.find ty xy in + check_val "update tag" (Some vx) vx'; + S.status tx |> fun tagx' -> + S.status ty |> fun tagy' -> + check (S.Status.t repo) "tagx" (`Branch tagx) tagx'; + check (S.Status.t repo) "tagy" (`Branch tagy) tagy'; + let* t = S.main repo in + S.Repo.close repo >>= fun () -> + Lwt.catch + (fun () -> + let+ _ = S.set_exn t ~info:(infof "add after close") [ "a" ] "bar" in + Alcotest.fail "Add after close should not be allowed") + (function Irmin.Closed -> Lwt.return_unit | exn -> Lwt.fail exn) + in + run x test + + let test_atomic x () = + let test repo = + let check_commit = check T.(option (S.commit_t repo)) in + let* t = S.main repo in + let* _c_empty = + S.test_set_and_get_exn t ~info:(infof "init") [ "a"; "b" ] ~test:None + ~set:(Some v1) + in + let* c_none = + S.test_set_and_get_exn t ~info:(infof "init") [ "a"; "b" ] + ~test:(Some v1) ~set:(Some v1) + in + check_commit "No commit" None c_none; + let message0 = "first" in + let message1 = "second" in + let v3 = "v3" in + let* c0 = + S.test_set_and_get_exn t ~info:(infof "%s" message0) [ "a"; "b" ] + ~test:(Some v1) ~set:(Some v2) + in + let c0 = Option.get c0 in + let c0_message = S.Commit.info c0 |> S.Info.message in + Alcotest.(check string) "commit0" message0 c0_message; + let* c1 = + S.test_set_and_get_exn t ~info:(infof "%s" message1) [ "a"; "b" ] + ~test:(Some v2) ~set:(Some v3) + in + let* c0_store = S.of_commit c0 in + let* v2' = S.get c0_store [ "a"; "b" ] in + Alcotest.(check string) "commit0 value" v2 v2'; + let* c1_store = S.of_commit (Option.get c1) in + let* v3' = S.get c1_store [ "a"; "b" ] in + Alcotest.(check string) "commit1 value" v3 v3'; + S.Repo.close repo + in + run x test + + let stats_t = Alcotest.testable (Irmin.Type.pp_dump S.Tree.stats_t) ( = ) + + let empty_stats = + { S.Tree.nodes = 0; leafs = 0; skips = 0; depth = 0; width = 0 } + + let inspect = + Alcotest.testable + (fun ppf -> function + | `Contents -> Fmt.string ppf "contents" + | `Node `Key -> Fmt.string ppf "key" + | `Node `Map -> Fmt.string ppf "map" + | `Node `Value -> Fmt.string ppf "value" + | `Node `Portable_dirty -> Fmt.string ppf "portable_dirty" + | `Node `Pruned -> Fmt.string ppf "pruned") + ( = ) + + let test_tree_caches x () = + let test repo = + let info = S.Info.none in + let* t1 = S.main repo in + S.set_exn t1 ~info [ "a"; "b" ] "foo" >>= fun () -> + (* Testing cache *) + S.Tree.reset_counters (); + let* v = S.get_tree t1 [] in + Alcotest.(check inspect) "inspect" (`Node `Key) (S.Tree.inspect v); + let* v = S.Tree.add v [ "foo" ] "foo" in + Alcotest.(check inspect) "inspect:0" (`Node `Value) (S.Tree.inspect v); + Alcotest.(check int) "val-v:0" 0 (S.Tree.counters ()).node_val_v; + let* v = S.Tree.add v [ "bar"; "foo" ] "bar" in + Alcotest.(check inspect) "inspect:1" (`Node `Value) (S.Tree.inspect v); + Alcotest.(check int) "val-v:1" 0 (S.Tree.counters ()).node_val_v; + Alcotest.(check int) "val-list:1" 0 (S.Tree.counters ()).node_val_list; + let _ = S.Tree.hash v in + Alcotest.(check inspect) "inspect:2" (`Node `Value) (S.Tree.inspect v); + Alcotest.(check int) "val-v:2" 1 (S.Tree.counters ()).node_val_v; + Alcotest.(check int) "val-list:2" 0 (S.Tree.counters ()).node_val_list; + S.set_tree_exn t1 ~info [] v >>= fun () -> + Alcotest.(check inspect) "inspect:3" (`Node `Key) (S.Tree.inspect v); + Alcotest.(check int) "val-v:3" 2 (S.Tree.counters ()).node_val_v; + Alcotest.(check int) "val-list:3" 0 (S.Tree.counters ()).node_val_list; + B.Repo.close repo + in + run x test + + let pp_depth = Irmin.Type.pp S.Tree.depth_t + let pp_key = Irmin.Type.pp S.Path.t + let contents_t = T.pair S.contents_t S.metadata_t + let diff_t = T.(pair S.path_t (Irmin.Diff.t contents_t)) + let check_diffs = checks diff_t + let check_ls = checks T.(pair S.step_t S.tree_t) + + let test_trees x () = + let test repo = + let* t = S.main repo in + let nodes = random_nodes 100 in + let foo1 = random_value 10 in + let foo2 = random_value 10 in + let* v1 = + S.Tree.singleton [ "foo"; "bar"; "toto" ] foo2 + |> with_binding [ "foo"; "toto" ] foo1 + in + S.Tree.clear v1; + let* () = + let dont_skip k = + Alcotest.failf "should not have skipped: '%a'" pp_key k + in + S.Tree.fold ~depth:(`Eq 1) ~force:(`False dont_skip) v1 () + in + let* () = + S.Tree.fold ~depth:(`Eq 1) ~force:`True (S.Tree.empty ()) () + ~contents:(fun k _ -> + assert (List.length k = 1); + Alcotest.fail "contents") + ~node:(fun k _ -> + assert (List.length k = 1); + Alcotest.fail "node") + in + let fold depth ecs ens = + let* cs, ns = + S.Tree.fold v1 ?depth ~force:`True ~cache:false + ~contents:(fun path _ (cs, ns) -> Lwt.return (path :: cs, ns)) + ~node:(fun path _ (cs, ns) -> Lwt.return (cs, path :: ns)) + ([], []) + in + let paths = slist (testable S.Path.t) compare in + Alcotest.(check paths) + (Fmt.str "contents depth=%a" Fmt.(Dump.option pp_depth) depth) + ecs cs; + Alcotest.(check paths) + (Fmt.str "nodes depth=%a" Fmt.(Dump.option pp_depth) depth) + ens ns; + Lwt.return () + in + let* () = + fold None + [ [ "foo"; "bar"; "toto" ]; [ "foo"; "toto" ] ] + [ []; [ "foo" ]; [ "foo"; "bar" ] ] + in + fold (Some (`Eq 0)) [] [ [] ] >>= fun () -> + fold (Some (`Eq 1)) [] [ [ "foo" ] ] >>= fun () -> + let* () = + fold (Some (`Eq 2)) [ [ "foo"; "toto" ] ] [ [ "foo"; "bar" ] ] + in + fold (Some (`Lt 2)) [] [ []; [ "foo" ] ] >>= fun () -> + let* () = + fold + (Some (`Le 2)) + [ [ "foo"; "toto" ] ] + [ []; [ "foo" ]; [ "foo"; "bar" ] ] + in + let* () = + fold + (Some (`Ge 2)) + [ [ "foo"; "toto" ]; [ "foo"; "bar"; "toto" ] ] + [ [ "foo"; "bar" ] ] + in + fold (Some (`Gt 2)) [ [ "foo"; "bar"; "toto" ] ] [] >>= fun () -> + let* v1 = S.Tree.remove v1 [ "foo"; "bar"; "toto" ] in + let* v = S.Tree.find v1 [ "foo"; "toto" ] in + Alcotest.(check (option string)) "remove" (Some foo1) v; + let v1 = S.Tree.empty () in + let* s = S.Tree.stats v1 in + Alcotest.(check stats_t) "empty stats" empty_stats s; + let* v1 = S.Tree.add v1 [ "foo"; "1" ] foo1 in + let* v1 = S.Tree.add v1 [ "foo"; "2" ] foo2 in + let* s = S.Tree.stats v1 in + Alcotest.(check stats_t) + "stats 1" + { S.Tree.nodes = 2; leafs = 2; skips = 0; depth = 2; width = 2 } + s; + let* v1 = S.Tree.remove v1 [ "foo"; "1" ] in + let* v1 = S.Tree.remove v1 [ "foo"; "2" ] in + let* s = S.Tree.stats v1 in + Alcotest.(check stats_t) "empty stats" empty_stats s; + S.set_tree_exn t ~info:(infof "empty tree") [] v1 >>= fun () -> + let* head = S.Head.get t in + S.Commit.key head |> fun head -> + let* commit = B.Commit.find (ct repo) head in + let node = B.Commit.Val.node (get commit) in + let* node = B.Node.find (n repo) node in + check + T.(option B.Node.Val.t) + "empty tree" + (Some (B.Node.Val.empty ())) + node; + + (* Testing [Tree.diff] *) + let contents_t = T.pair S.contents_t S.metadata_t in + let diff = T.(pair S.path_t (Irmin.Diff.t contents_t)) in + let check_diffs = checks diff in + let check_val = check T.(option contents_t) in + let check_ls = checks T.(pair S.step_t S.tree_t) in + let normal c = Some (c, S.Metadata.default) in + let d0 = S.Metadata.default in + let v0 = S.Tree.empty () in + let v1 = S.Tree.empty () in + let v2 = S.Tree.empty () in + let* v1 = S.Tree.add v1 [ "foo"; "1" ] foo1 in + let* f = S.Tree.find_all v1 [ "foo"; "1" ] in + check_val "tree update" (normal foo1) f; + let* v1' = S.Tree.add v1 [ "foo"; "1" ] foo1 in + Alcotest.(check bool) "Tree.add keeps sharing" true (v1 == v1'); + let* v1' = S.Tree.remove v1 [ "foo"; "2" ] in + Alcotest.(check bool) "Tree.remove keeps sharing" true (v1 == v1'); + let* v1' = S.Tree.add_tree v1 [] v1 in + Alcotest.(check bool) "Tree.add_tree keeps sharing" true (v1 == v1'); + let* v2 = S.Tree.add v2 [ "foo"; "1" ] foo2 in + let* v2 = S.Tree.add v2 [ "foo"; "2" ] foo1 in + let* d1 = S.Tree.diff v0 v1 in + check_diffs "diff 1" [ ([ "foo"; "1" ], `Added (foo1, d0)) ] d1; + let* d2 = S.Tree.diff v1 v0 in + check_diffs "diff 2" [ ([ "foo"; "1" ], `Removed (foo1, d0)) ] d2; + let* d3 = S.Tree.diff v1 v2 in + check_diffs "diff 3" + [ + ([ "foo"; "1" ], `Updated ((foo1, d0), (foo2, d0))); + ([ "foo"; "2" ], `Added (foo1, d0)); + ] + d3; + let* v3 = S.Tree.add v2 [ "foo"; "bar"; "1" ] foo1 in + let* d4 = S.Tree.diff v2 v3 in + check_diffs "diff 4" [ ([ "foo"; "bar"; "1" ], `Added (foo1, d0)) ] d4; + let* d5 = S.Tree.diff v3 v2 in + check_diffs "diff 4" [ ([ "foo"; "bar"; "1" ], `Removed (foo1, d0)) ] d5; + + (* Testing length *) + let check_length msg t = + let* n = S.Tree.length t [] in + let+ l = S.Tree.list t [] in + Alcotest.(check int) msg n (List.length l) + in + let* () = check_length "bindings1 length" v2 in + let* () = + let t = contents "foo" in + check_length "contents length" t + in + + (* Testing paginated lists *) + let tree = + let c ?(info = S.Metadata.default) blob = `Contents (blob, info) in + S.Tree.of_concrete + (`Tree + [ + ("aa", c "0"); + ("a", c "1"); + ("bbb", c "3"); + ("b", c "3"); + ("aaa", c "1"); + ]) + in + let* _ = S.set_tree_exn t ~info:(infof "add tree") [] tree in + let* e = S.Tree.get_tree tree [ "a" ] in + let ls = + [ + ("aa", contents "0"); + ("a", e); + ("bbb", contents "3"); + ("b", contents "3"); + ("aaa", e); + ] + in + let* () = + let* l1 = S.Tree.list ~offset:0 ~length:2 tree [] in + let* l2 = S.Tree.list ~offset:2 ~length:2 tree [] in + let+ l3 = S.Tree.list ~offset:4 ~length:2 tree [] in + Alcotest.(check int) "size l1" 2 (List.length l1); + Alcotest.(check int) "size l2" 2 (List.length l2); + Alcotest.(check int) "size l3" 1 (List.length l3); + check_ls "2 paginated list" ls (l1 @ l2 @ l3) + in + let* () = + let* l1 = S.Tree.list ~offset:0 ~length:3 tree [] in + let+ l2 = S.Tree.list ~offset:3 ~length:6 tree [] in + Alcotest.(check int) "size l1" 3 (List.length l1); + Alcotest.(check int) "size l2" 2 (List.length l2); + check_ls "3 paginated list" ls (l1 @ l2) + in + let* () = + let* l1 = S.Tree.list ~offset:0 ~length:4 tree [] in + let+ l2 = S.Tree.list ~offset:4 ~length:4 tree [] in + Alcotest.(check int) "size l1" 4 (List.length l1); + Alcotest.(check int) "size l2" 1 (List.length l2); + check_ls "4 paginated list" ls (l1 @ l2) + in + let* () = + let* l1 = S.Tree.list ~offset:0 ~length:5 tree [] in + let+ l2 = S.Tree.list ~offset:5 ~length:5 tree [] in + Alcotest.(check int) "size l1" 5 (List.length l1); + Alcotest.(check int) "size l2" 0 (List.length l2); + check_ls "5 paginated list" ls (l1 @ l2) + in + let* c0 = + S.Tree.singleton [ "foo"; "a" ] "1" + |> with_binding [ "foo"; "b"; "c" ] "2" + >>= with_binding [ "foo"; "c" ] "3" + >>= with_binding [ "foo"; "d" ] "4" + in + let* b = S.Tree.get_tree c0 [ "foo"; "b" ] in + let* ls = S.Tree.list c0 [ "foo" ] in + check_ls "list all" + [ + ("a", contents "1"); ("b", b); ("c", contents "3"); ("d", contents "4"); + ] + ls; + let* ls = S.Tree.list ~offset:2 c0 [ "foo" ] in + check_ls "list offset=2" [ ("c", contents "3"); ("d", contents "4") ] ls; + let* ls = S.Tree.list ~offset:2 ~length:1 c0 [ "foo" ] in + check_ls "list offset=2 length=1" [ ("c", contents "3") ] ls; + let* ls = S.Tree.list ~length:1 c0 [ "foo" ] in + check_ls "list length=1" [ ("a", contents "1") ] ls; + + (* Testing concrete representation *) + let* c0 = + Lwt.return (S.Tree.empty ()) + >>= with_binding [ "foo"; "a" ] "1" + >>= with_binding [ "foo"; "b"; "c" ] "2" + >>= with_binding [ "bar"; "d" ] "3" + >>= with_binding [ "e" ] "4" + in + let* t0 = c0 |> S.Tree.to_concrete >|= S.Tree.of_concrete in + let* () = + let+ d0 = S.Tree.diff c0 t0 in + check_diffs "concrete roundtrip" [] d0 + in + let* () = + let* c0' = S.Tree.list c0 [] in + let+ t0' = S.Tree.list t0 [] in + check_ls "concrete list /" c0' t0' + in + let* () = + let* c0' = S.Tree.list c0 [ "foo" ] in + let+ t0' = S.Tree.list t0 [ "foo" ] in + check_ls "concrete tree list /foo" c0' t0' + in + let* () = + let* c0' = S.Tree.list c0 [ "bar"; "d" ] in + let+ t0' = S.Tree.list t0 [ "bar"; "d" ] in + check_ls "concrete tree list /bar/d" c0' t0' + in + + (* Testing other tree operations. *) + let v0 = S.Tree.empty () in + let* c = S.Tree.to_concrete v0 in + (match c with + | `Tree [] -> () + | _ -> Alcotest.fail "Excpected empty tree"); + let* v0 = S.Tree.add v0 [] foo1 in + let* foo1' = S.Tree.find_all v0 [] in + check_val "read /" (normal foo1) foo1'; + let* v0 = S.Tree.add v0 [ "foo"; "1" ] foo1 in + let* foo1' = S.Tree.find_all v0 [ "foo"; "1" ] in + check_val "read foo/1" (normal foo1) foo1'; + let* v0 = S.Tree.add v0 [ "foo"; "2" ] foo2 in + let* foo2' = S.Tree.find_all v0 [ "foo"; "2" ] in + check_val "read foo/2" (normal foo2) foo2'; + let check_tree v = + let* ls = S.Tree.list v [ "foo" ] in + check_ls "path1" [ ("1", contents foo1); ("2", contents foo2) ] ls; + let* foo1' = S.Tree.find_all v [ "foo"; "1" ] in + check_val "foo1" (normal foo1) foo1'; + let* foo2' = S.Tree.find_all v [ "foo"; "2" ] in + check_val "foo2" (normal foo2) foo2'; + Lwt.return_unit + in + let* v0 = + Lwt_list.fold_left_s (fun v0 (k, v) -> S.Tree.add v0 k v) v0 nodes + in + check_tree v0 >>= fun () -> + S.set_tree_exn t ~info:(infof "update_path b/") [ "b" ] v0 >>= fun () -> + S.set_tree_exn t ~info:(infof "update_path a/") [ "a" ] v0 >>= fun () -> + let* ls = S.list t [ "b"; "foo" ] in + check_ls "path2" [ ("1", contents foo1); ("2", contents foo2) ] ls; + let* foo1' = S.find_all t [ "b"; "foo"; "1" ] in + check_val "foo1" (normal foo1) foo1'; + let* foo2' = S.find_all t [ "a"; "foo"; "2" ] in + check_val "foo2" (normal foo2) foo2'; + let* v0 = S.get_tree t [ "b" ] in + check_tree v0 >>= fun () -> + S.set_exn t ~info:(infof "update b/x") [ "b"; "x" ] foo1 >>= fun () -> + let* v2 = S.get_tree t [ "b" ] in + let* v1 = S.Tree.add v0 [ "y" ] foo2 in + let* v' = + Irmin.Merge.(f S.Tree.merge ~old:(promise v0) v1 v2) + >>= merge_exn "merge trees" + in + S.set_tree_exn t ~info:(infof "merge_path") [ "b" ] v' >>= fun () -> + let* foo1' = S.find_all t [ "b"; "x" ] in + let* foo2' = S.find_all t [ "b"; "y" ] in + check_val "merge: b/x" (normal foo1) foo1'; + check_val "merge: b/y" (normal foo2) foo2'; + let* () = + Lwt_list.iteri_s + (fun i (k, v) -> + let* v' = S.find_all t ("a" :: k) in + check_val ("a" ^ string_of_int i) (normal v) v'; + let* v' = S.find_all t ("b" :: k) in + check_val ("b" ^ string_of_int i) (normal v) v'; + Lwt.return_unit) + nodes + in + let* v2 = S.get_tree t [ "b" ] in + let* _ = S.Tree.find_all v2 [ "foo"; "1" ] in + let* v2 = S.Tree.add v2 [ "foo"; "1" ] foo2 in + S.set_tree_exn t ~info:(infof "v2") [ "b" ] v2 >>= fun () -> + let* foo2' = S.find_all t [ "b"; "foo"; "1" ] in + check_val "update tree" (normal foo2) foo2'; + let* v3 = S.get_tree t [ "b" ] in + let* _ = S.Tree.find_all v3 [ "foo"; "1" ] in + let* v3 = S.Tree.remove v3 [ "foo"; "1" ] in + S.set_tree_exn t ~info:(infof "v3") [ "b" ] v3 >>= fun () -> + let* foo2' = S.find_all t [ "b"; "foo"; "1" ] in + check_val "remove tree" None foo2'; + let* r1 = r1 ~repo in + let* r2 = r2 ~repo in + let i0 = S.Info.empty in + let* c = + S.Commit.v repo ~info:S.Info.empty + ~parents:[ S.Commit.key r1; S.Commit.key r2 ] + v3 + in + S.Head.set t c >>= fun () -> + let* h = S.Head.get t in + S.Commit.info h |> fun i -> + check S.Info.t "commit info" i0 i; + let* tt = S.of_commit h in + let* g = S.history tt in + let pred = S.History.pred g h in + checks (S.commit_t repo) "head" [ r1; r2 ] pred; + let* foo2'' = S.find_all tt [ "b"; "foo"; "1" ] in + check_val "remove tt" None foo2''; + let vx = "VX" in + let px = [ "x"; "y"; "z" ] in + S.set_exn tt ~info:(infof "update") px vx >>= fun () -> + let* tree = S.get_tree tt [] in + S.Tree.clear tree; + let* s = S.Tree.stats tree in + Alcotest.(check stats_t) + "lazy stats" + { S.Tree.nodes = 0; leafs = 0; skips = 1; depth = 0; width = 0 } + s; + S.Tree.clear tree; + let* s = S.Tree.stats ~force:true tree in + Alcotest.(check stats_t) + "forced stats" + { S.Tree.nodes = 404; leafs = 103; skips = 0; depth = 5; width = 103 } + s; + let* vx' = S.Tree.find_all tree px in + check_val "updates" (normal vx) vx'; + let v = S.Tree.singleton [] vx in + let* () = + S.set_tree_exn t ~info:(infof "update file as tree") [ "a" ] v + in + let* vx' = S.find_all t [ "a" ] in + check_val "update file as tree" (normal vx) vx'; + B.Repo.close repo + in + run x test + + (* let pp_proof = Irmin.Type.pp S.Tree.Proof.t *) + + let test_proofs x () = + let test repo = + (* Testing Merkle proof *) + let large_dir = + List.init 1000 (fun i -> + let v = string_of_int i in + ([ "dir"; v ], "BLOB:" ^ v)) + in + let* c0 = + Lwt.return (S.Tree.empty ()) + >>= with_binding [ "foo"; "a" ] "1" + >>= with_binding [ "foo"; "b"; "c" ] "2" + >>= with_binding [ "bar"; "d" ] "3" + >>= with_binding [ "e" ] "4" + >>= fun t -> + Lwt_list.fold_left_s (fun acc (k, v) -> S.Tree.add acc k v) t large_dir + in + let to_proof t = + let* store = S.empty repo in + let* () = S.set_tree_exn ~info:(infof "to_proof") store [] t in + let key = + match S.Tree.key t with None -> assert false | Some k -> k + in + let rec aux p t = + let* bindings = + Lwt.catch + (fun () -> S.Tree.list t []) + (function + | S.Tree.Pruned_hash _ -> Lwt.return [] | e -> Lwt.fail e) + in + Lwt_list.iter_s (fun (s, v) -> aux (p @ [ s ]) v) bindings + in + S.Tree.produce_proof repo key (fun t -> + let+ () = aux [] t in + (t, ())) + in + let* p0, () = to_proof c0 in + (* [%log.debug "p0=%a" pp_proof p0]; *) + let t0 = S.Tree.Proof.to_tree p0 in + let* () = + let+ d0 = S.Tree.diff c0 t0 in + check_diffs "proof roundtrip" [] d0 + in + let* () = + let* c0' = S.Tree.list c0 [] in + let+ t0' = S.Tree.list t0 [] in + check_ls "proof list /" c0' t0' + in + let* () = + let* c0' = S.Tree.list c0 [ "foo" ] in + let+ t0' = S.Tree.list t0 [ "foo" ] in + check_ls "proof tree list /foo" c0' t0' + in + let* () = + let* c0' = S.Tree.list c0 [ "bar"; "d" ] in + let+ t0' = S.Tree.list t0 [ "bar"; "d" ] in + check_ls "proof tree list /bar/d" c0' t0' + in + let* () = + let* c0' = S.Tree.list c0 [ "dir" ] in + let+ t0' = S.Tree.list t0 [ "dir" ] in + check_ls "proof tree list /dir" c0' t0' + in + let add_noise n prefix = + List.map (fun k -> (prefix @ [ k ], k)) (List.init n string_of_int) + in + let bindings = + [ + ([ "foo"; "age" ], "0"); + ([ "foo"; "version" ], "1"); + ([ "bar"; "age" ], "2"); + ([ "bar"; "version" ], "3"); + ] + @ add_noise 100 [ "foo" ] + @ add_noise 10 [ "hey" ] + @ add_noise 50 [ "bar" ] + in + let increment = function + | None -> assert false + | Some i -> Some (int_of_string i + 1 |> string_of_int) + in + let check_proof_f0 p = + let t = S.Tree.Proof.to_tree p in + let* i = S.Tree.find t [ "bar"; "age" ] in + Alcotest.(check (option string)) + "inside: find bar/age in proof" (Some "2") i; + let* i = S.Tree.find t [ "bar"; "version" ] in + Alcotest.(check (option string)) + "inside: find bar/version in proof" (Some "3") i; + let* i = S.Tree.find t [ "hello"; "there" ] in + Alcotest.(check (option string)) + "inside: do not find hello/there in proof" None i; + let+ () = + Lwt.catch + (fun () -> + let+ _ = S.Tree.find t [ "foo"; "version" ] in + Alcotest.fail "inside: should have raise: pruned_hash exn") + (function + | S.Tree.Pruned_hash _ | B.Node.Val.Dangling_hash _ -> + Lwt.return () + | e -> Lwt.fail e) + in + () + in + + let check_proof_f1 p = + let t = S.Tree.Proof.to_tree p in + let+ i = S.Tree.find t [ "foo"; "version" ] in + Alcotest.(check (option string)) + "outside: find foo/version" (Some "1") i + in + + let init_tree bindings = + let tree = S.Tree.empty () in + let* tree = + Lwt_list.fold_left_s + (fun tree (k, v) -> S.Tree.add tree k v) + tree bindings + in + let* store = S.empty repo in + let* () = S.set_tree_exn ~info:(infof "init_tree") store [] tree in + S.tree store + in + let* tree = init_tree bindings in + let key = + match S.Tree.key tree with None -> assert false | Some k -> k + in + + let f0 t0 = + let* t1 = S.Tree.update t0 [ "foo"; "age" ] increment in + let* t2 = S.Tree.update t1 [ "bar"; "age" ] increment in + let* t3 = S.Tree.get_tree t2 [ "bar" ] in + let* t4 = S.Tree.add_tree t2 [ "hello"; "there" ] t3 in + let* v = S.Tree.get t4 [ "hello"; "there"; "version" ] in + Alcotest.(check string) "hello/there/version" "3" v; + let t = S.Tree.empty () in + let* t5 = S.Tree.add_tree t [ "dir1"; "dir2" ] t4 in + let* v = S.Tree.get t5 [ "dir1"; "dir2"; "bar"; "age" ] in + Alcotest.(check string) "dir1/dir2/bar/age" "3" v; + let* t = S.Tree.remove t4 [ "bar" ] in + + (* Trigger certain paths in [S.Tree] during "verify" *) + let portable = + (* During "verify" [portable] is [Pruned] with [portable] in env *) + t0 + in + let portable_dirty = t in + let trigger_node_to_map t = + S.Tree.fold ~depth:(`Eq 1) ~order:`Sorted ~force:`True t () + in + let* () = trigger_node_to_map portable in + let* () = trigger_node_to_map portable_dirty in + let trigger_node_length t = + let+ (_ : int) = S.Tree.length t [] in + () + in + let* () = trigger_node_length portable in + let* () = trigger_node_length portable_dirty in + let trigger_node_fold_undefined t = + S.Tree.fold ~depth:(`Eq 1) ~order:`Undefined ~force:`True t () + in + let* () = trigger_node_fold_undefined portable in + let* () = trigger_node_fold_undefined portable_dirty in + let (_ : bool) = S.Tree.is_empty portable in + let trigger_node_to_backend_portable t = + match S.Tree.destruct t with + | `Contents _ -> assert false + | `Node n -> + let+ _ = S.to_backend_portable_node n in + () + in + let* () = trigger_node_to_backend_portable portable_dirty in + + Lwt.return (t, ()) + in + let f1 t0 = + let* p0, () = S.Tree.produce_proof repo key f0 in + let* () = check_proof_f0 p0 in + let+ v = S.Tree.get t0 [ "foo"; "version" ] in + Alcotest.(check string) "foo/version" "1" v; + (t0, ()) + in + let* p, () = S.Tree.produce_proof repo key f1 in + + let* () = check_proof_f1 p in + + let check_proof f = + let* p, () = S.Tree.produce_proof repo key f in + (* [%log.debug "Verifying proof %a" pp_proof p]; *) + let+ r = S.Tree.verify_proof p f in + match r with + | Ok (_, ()) -> () + | Error e -> + Alcotest.failf "check_proof: %a" + (Irmin.Type.pp S.Tree.verifier_error_t) + e + in + let* () = Lwt_list.iter_s check_proof [ f0; f1 ] in + + (* check env sharing *) + let tree () = + S.Tree.of_concrete + (`Tree [ ("foo", `Contents ("bar", S.Metadata.default)) ]) + in + let contents () = + S.Tree.of_concrete (`Contents ("bar", S.Metadata.default)) + in + let check_env_empty msg t b = + let env = S.Tree.Private.get_env t in + Alcotest.(check bool) msg b (S.Tree.Private.Env.is_empty env) + in + let check_env msg t t' = + let env = S.Tree.Private.get_env t in + let env' = S.Tree.Private.get_env t' in + check S.Tree.Private.Env.t msg env env' + in + let x = ref None in + let* _ = + S.Tree.produce_proof repo key (fun t -> + check_env_empty "env should be set inside the proof" t false; + x := Some t; + + let t0 = tree () in + check_env_empty "env should not be set for fresh trees" t0 true; + + (* test changing subtress: check that envirnoment is + attached only the tree roots *) + let* t1 = S.Tree.add_tree t [ "foo" ] t0 in + check_env_empty "1: t's env should not change" t false; + check_env_empty "1: t0's env should not change" t0 true; + check_env "1: t1's env should be the same as t's" t1 t; + + let t0 = contents () in + let* t1 = S.Tree.add_tree t [ "foo" ] t0 in + check_env_empty "2: t's env should not change" t false; + check_env_empty "2: t0's env should not change" t0 true; + check_env "2: t1's env should be the same as t's" t1 t; + + (* test changing roots *) + let t0 = tree () in + let* t1 = S.Tree.add_tree t [] t0 in + check_env_empty "3: t's env should not change" t false; + check_env_empty "3: t0's env should not change" t0 true; + check_env "3: t1's env should be the same as t0's" t1 t0; + + let t0 = contents () in + let* t1 = S.Tree.add_tree t [] t0 in + check_env_empty "4: t's env should not change" t false; + check_env_empty "4: t0's env should not change" t0 true; + check_env "4: t1's env should be the same as t0's" t1 t0; + + (* check subtrees *) + let* t2 = S.Tree.get_tree t [ "foo" ] in + check_env "5: t2's env should be the same as t's" t2 t; + let* t3 = S.Tree.get_tree t [ "foo"; "age" ] in + check_env "5: t3's env should be the same as t's" t3 t; + + Lwt.return (t, ())) + in + let t = match !x with Some t -> t | None -> assert false in + check_env_empty "env is unset outside of the proof)" t true; + + (* test negative proofs *) + let check_bad_proof p = + let+ r = S.Tree.verify_proof p f0 in + match r with + | Ok _ -> Alcotest.fail "verify should have failed" + | Error _ -> () + in + + let* p0, () = S.Tree.produce_proof repo key f0 in + let proof ?(before = S.Tree.Proof.before p0) + ?(after = S.Tree.Proof.after p0) ?(state = S.Tree.Proof.state p0) () = + S.Tree.Proof.v ~before ~after state + in + let wrong_hash = B.Contents.Hash.hash "not the right hash!" in + let wrong_kinded_hash = `Node wrong_hash in + let* () = check_bad_proof (proof ~before:wrong_kinded_hash ()) in + let* () = check_bad_proof (proof ~after:wrong_kinded_hash ()) in + let* _ = S.Tree.verify_proof (proof ()) f0 in + let some_contents : S.Tree.Proof.tree list = + [ + Blinded_node wrong_hash; + Node []; + Inode { length = 1024; proofs = [] }; + Blinded_contents (wrong_hash, S.Metadata.default); + Contents ("yo", S.Metadata.default); + ] + in + let* () = + Lwt_list.iter_s + (fun c -> check_bad_proof (proof ~state:c ())) + some_contents + in + B.Repo.close repo + in + run x test + + let test_wide_nodes x () = + let test repo = + let size = 500_000 in + let c0 = S.Tree.empty () in + let rec wide_node i c = + if i >= size then Lwt.return c + else + S.Tree.add c [ "foo"; string_of_int i ] (string_of_int i) >>= fun c -> + wide_node (i + 1) c + in + wide_node 0 c0 >>= fun c -> + S.Tree.list c [ "foo" ] >>= fun ls -> + Alcotest.(check int) "list wide dir" size (List.length ls); + S.Tree.fold ~force:`True c ~uniq:`False + ~contents:(fun k _ i -> + Alcotest.(check int) "contents at [foo; i]" (List.length k) 2; + Lwt.return (i + 1)) + ~node:(fun k _ i -> + if not (List.length k = 0 || List.length k = 1) then + Alcotest.failf "nodes should be at [] and [foo], got %a" + (Irmin.Type.pp S.path_t) k; + Lwt.return i) + 0 + >>= fun nb_contents -> + Alcotest.(check int) "nb of contents folded over" size nb_contents; + S.Tree.remove c [ "foo"; "499999" ] >>= fun c1 -> + S.Tree.add c0 [] "499999" >>= fun c2 -> + S.Tree.add_tree c1 [ "foo"; "499999" ] c2 >>= fun c' -> + let h' = S.Tree.hash c' in + let h = S.Tree.hash c in + check S.Hash.t "same tree" h h'; + let* c1 = S.Tree.get_tree c [ "foo" ] in + let* _ = + S.Backend.Repo.batch repo (fun c n _ -> S.save_tree repo c n c1) + in + (match S.Tree.destruct c1 with + | `Contents _ -> Alcotest.fail "got `Contents, expected `Node" + | `Node node -> ( + let* v = S.to_backend_node node in + let () = + let ls = B.Node.Val.list v in + Alcotest.(check int) "list wide node" size (List.length ls) + in + let* bar_key = with_contents repo (fun t -> B.Contents.add t "bar") in + let k = normal bar_key in + let v1 = B.Node.Val.add v "x" k in + let* () = + let h' = B.Node.Hash.hash v1 in + let+ h = with_node repo (fun n -> B.Node.add n v1) in + check B.Node.Hash.t "wide node + x: hash(v) = add(v)" + (B.Node.Key.to_hash h) h' + in + let () = + let v2 = B.Node.Val.add v "x" k in + check B.Node.Val.t "add x" v1 v2 + in + let () = + let v0 = B.Node.Val.remove v1 "x" in + check B.Node.Val.t "remove x" v v0 + in + let* () = + let v3 = B.Node.Val.remove v "1" in + let h' = B.Node.Hash.hash v3 in + with_node repo (fun n -> B.Node.add n v3) >|= fun h -> + check B.Node.Hash.t "wide node - 1 : hash(v) = add(v)" + (B.Node.Key.to_hash h) h' + in + (match B.Node.Val.find v "499999" with + | None | Some (`Node _) -> Alcotest.fail "value 499999 not found" + | Some (`Contents (x, _)) -> + let x = B.Contents.Key.to_hash x in + let x' = B.Contents.Hash.hash "499999" in + check B.Contents.Hash.t "find 499999" x x'); + match B.Node.Val.find v "500000" with + | None -> Lwt.return_unit + | Some _ -> Alcotest.fail "value 500000 should not be found")) + >>= fun () -> B.Repo.close repo + in + run x test + + let test_commit_wide_node x () = + let test repo = + let size = 500_000 in + let c0 = S.Tree.empty () in + let rec wide_node i c = + if i >= size then Lwt.return c + else + S.Tree.add c [ "foo"; string_of_int i ] (string_of_int i) >>= fun c -> + wide_node (i + 1) c + in + wide_node 0 c0 >>= fun c -> + S.main repo >>= fun t -> + S.set_tree_exn t [ "wide" ] ~info:(infof "commit_wide_nodes") c + >>= fun () -> + S.list t [ "wide"; "foo" ] >>= fun ls -> + Alcotest.(check int) "commit wide node list" size (List.length ls); + B.Repo.close repo + in + run x test + + module Sync = Irmin.Sync.Make (S) + + let test_sync x () = + let test repo = + let* t1 = S.main repo in + S.set_exn t1 ~info:(infof "update a/b") [ "a"; "b" ] v1 >>= fun () -> + let* h = S.Head.get t1 in + let* _r1 = S.Head.get t1 in + S.set_exn t1 ~info:(infof "update a/c") [ "a"; "c" ] v2 >>= fun () -> + let* r2 = S.Head.get t1 in + S.set_exn t1 ~info:(infof "update a/d") [ "a"; "d" ] v1 >>= fun () -> + let* _r3 = S.Head.get t1 in + let* h = S.history t1 ~min:[ h ] in + Alcotest.(check int) "history-v" 3 (S.History.nb_vertex h); + Alcotest.(check int) "history-e" 2 (S.History.nb_edges h); + let remote = Irmin.remote_store (module S) t1 in + let* partial = Sync.fetch_exn t1 ~depth:0 remote in + let partial = + match partial with + | `Head x -> x + | `Empty -> failwith "no head: partial" + in + let* full = Sync.fetch_exn t1 remote in + let full = + match full with `Head x -> x | `Empty -> failwith "no head: full" + in + (* Restart a fresh store and import everything in there. *) + let tag = "export" in + let* t2 = S.of_branch repo tag in + S.Head.set t2 partial >>= fun () -> + let* b1 = S.mem t2 [ "a"; "b" ] in + Alcotest.(check bool) "mem-ab" true b1; + let* b2 = S.mem t2 [ "a"; "c" ] in + Alcotest.(check bool) "mem-ac" true b2; + let* b3 = S.mem t2 [ "a"; "d" ] in + Alcotest.(check bool) "mem-ad" true b3; + let* v1' = S.get t2 [ "a"; "d" ] in + check S.contents_t "v1" v1 v1'; + S.Head.set t2 r2 >>= fun () -> + let* b4 = S.mem t2 [ "a"; "d" ] in + Alcotest.(check bool) "mem-ab" false b4; + S.Head.set t2 full >>= fun () -> + S.Head.set t2 r2 >>= fun () -> + let* b4 = S.mem t2 [ "a"; "d" ] in + Alcotest.(check bool) "mem-ad" false b4; + B.Repo.close repo + in + run x test + + module Dot = Irmin.Dot (S) + + let output_file x t file = + let buf = Buffer.create 1024 in + let date d = + let tm = Unix.localtime (Int64.to_float d) in + Fmt.str "%2d:%2d:%2d" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec + in + Dot.output_buffer t ~date buf >>= fun () -> + let oc = + open_out_bin + (Filename.get_temp_dir_name () / Fmt.str "%s-%s.dot" x.name file) + in + output_string oc (Buffer.contents buf); + close_out oc; + Lwt.return_unit + + let test_merge ?hook x () = + let test repo = + let v1 = "X1" in + let v2 = "X2" in + let v3 = "X3" in + let* t1 = S.main repo in + let* () = + S.set_exn t1 ~info:(infof "update a/b/a") [ "a"; "b"; "a" ] v1 + in + let* () = + S.set_exn t1 ~info:(infof "update a/b/b") [ "a"; "b"; "b" ] v2 + in + let* () = + S.set_exn t1 ~info:(infof "update a/b/c") [ "a"; "b"; "c" ] v3 + in + let test = "test" in + let* t2 = S.clone ~src:t1 ~dst:test in + let* () = + S.set_exn t1 ~info:(infof "update main:a/b/b") [ "a"; "b"; "b" ] v1 + in + let* () = + S.set_exn t1 ~info:(infof "update main:a/b/b") [ "a"; "b"; "b" ] v3 + in + let* () = + S.set_exn t2 ~info:(infof "update test:a/b/c") [ "a"; "b"; "c" ] v1 + in + output_file x t1 "before" >>= fun () -> + let* m = S.merge_into ~info:(infof "merge test into main") t2 ~into:t1 in + merge_exn "m" m >>= fun () -> + may_with_branch [ t1 ] repo hook >>= fun () -> + output_file x t1 "after" >>= fun () -> + let* v1' = S.get t1 [ "a"; "b"; "c" ] in + let* v2' = S.get t2 [ "a"; "b"; "b" ] in + let* v3' = S.get t1 [ "a"; "b"; "b" ] in + check S.contents_t "v1" v1 v1'; + check S.contents_t "v2" v2 v2'; + check S.contents_t "v3" v3 v3'; + B.Repo.close repo + in + run x test + + (* in this test an outdated reference to a tree is used by a commit: [tree] is + the tree with root [x] created by [c1] and modified by [c2]. [c3] reuse [tree] + which implicitly deletes the changes of [c2]. *) + let test_merge_outdated_tree x () = + let check_val = check T.(option S.contents_t) in + let none_fail f msg = + f >>= function None -> Alcotest.fail msg | Some c -> Lwt.return c + in + let test repo = + let vx = "VX" in + let vy = "VY" in + let old () = Lwt.return (Ok None) in + let* t = S.main repo in + S.set_exn t ~info:(infof "add x/y/z") [ "x"; "y"; "z" ] vx >>= fun () -> + let* _c1 = none_fail (S.Head.find t) "head not found" in + let* tree = S.get_tree t [ "x" ] in + S.set_exn t ~info:(infof "add u/x/y") [ "u"; "x"; "y" ] vy >>= fun () -> + let* c2 = none_fail (S.Head.find t) "head not found" in + let* tree3 = S.Tree.add tree [ "x"; "z" ] vx in + S.set_tree_exn t ~info:(infof "update") [ "u" ] tree3 >>= fun () -> + let* c3 = none_fail (S.Head.find t) "head not found" in + let info () = S.Commit.info c3 in + with_commit repo (fun commit_t -> + Irmin.Merge.f + (B.Commit.merge commit_t ~info) + ~old + (Some (S.Commit.key c3)) + (Some (S.Commit.key c2))) + >>= merge_exn "commit" + >>= function + | None -> Lwt.return_unit + | Some c4 -> + let* k = none_fail (S.Commit.of_key repo c4) "of hash" in + S.Branch.set repo "foo" k >>= fun () -> + let* t = S.of_branch repo "foo" in + let* vy' = S.find t [ "u"; "x"; "y" ] in + check_val "vy after merge" None vy'; + B.Repo.close repo + in + run x test + + let test_merge_unrelated ?hook x () = + run x @@ fun repo -> + let v1 = "X1" in + let* foo = S.of_branch repo "foo" in + let* bar = S.of_branch repo "bar" in + S.set_exn foo ~info:(infof "update foo:a") [ "a" ] v1 >>= fun () -> + S.set_exn bar ~info:(infof "update bar:b") [ "b" ] v1 >>= fun () -> + may_with_branch [ foo; bar ] repo hook >>= fun () -> + let* _ = + S.merge_into ~info:(infof "merge bar into foo") bar ~into:foo + >>= merge_exn "merge unrelated" + in + B.Repo.close repo + + let rec write fn = function + | 0 -> [] + | i -> (fun () -> fn i >>= Lwt.pause) :: write fn (i - 1) + + let perform l = Lwt_list.iter_p (fun f -> f ()) l + + let rec read fn check = function + | 0 -> [] + | i -> (fun () -> fn i >|= fun v -> check i v) :: read fn check (i - 1) + + let test_concurrent_low x () = + let test_branches repo = + let k = b1 in + let* v = r1 ~repo in + let write = write (fun _i -> S.Branch.set repo k v) in + let read = + read + (fun _i -> S.Branch.find repo k >|= get) + (fun i -> check (S.commit_t repo) (Fmt.str "tag %d" i) v) + in + perform (write 1) >>= fun () -> + perform (write 10 @ read 10 @ write 10 @ read 10) + in + let test_contents repo = + let* k = kv2 ~repo in + let v = v2 in + let t = B.Repo.contents_t repo in + let write = + write (fun _i -> + let* _ = with_contents repo (fun t -> B.Contents.add t v) in + Lwt.return_unit) + in + let read = + read + (fun _i -> B.Contents.find t k >|= get) + (fun i -> check S.contents_t (Fmt.str "contents %d" i) v) + in + perform (write 1) >>= fun () -> + perform (write 10 @ read 10 @ write 10 @ read 10) + in + run x (fun repo -> + Lwt.choose [ test_branches repo; test_contents repo ] >>= fun () -> + B.Repo.close repo) + + let test_concurrent_updates x () = + let test_one repo = + let k = [ "a"; "b"; "d" ] in + let v = "X1" in + let* t1 = S.main repo in + let* t2 = S.main repo in + let write t = + write (fun i -> S.set_exn t ~info:(infof "update: one %d" i) k v) + in + let read t = + read + (fun _ -> S.get t k) + (fun i -> check S.contents_t (Fmt.str "update: one %d" i) v) + in + perform (write t1 10 @ write t2 10) >>= fun () -> perform (read t1 10) + in + let test_multi repo = + let k i = [ "a"; "b"; "c"; string_of_int i ] in + let v i = Fmt.str "X%d" i in + let* t1 = S.main repo in + let* t2 = S.main repo in + let write t = + write (fun i -> + S.set_exn t ~info:(infof "update: multi %d" i) (k i) (v i)) + in + let read t = + read + (fun i -> S.get t (k i)) + (fun i -> check S.contents_t (Fmt.str "update: multi %d" i) (v i)) + in + perform (write t1 10 @ write t2 10) >>= fun () -> perform (read t1 10) + in + run x (fun repo -> + test_one repo >>= fun () -> + test_multi repo >>= fun () -> B.Repo.close repo) + + let test_concurrent_merges x () = + let test repo = + let k i = [ "a"; "b"; "c"; string_of_int i ] in + let v i = Fmt.str "X%d" i in + let* t1 = S.main repo in + let* t2 = S.main repo in + let write t n = + write (fun i -> + let tag = Fmt.str "tmp-%d-%d" n i in + let* m = S.clone ~src:t ~dst:tag in + S.set_exn m ~info:(infof "update") (k i) (v i) >>= fun () -> + Lwt.pause () >>= fun () -> + S.merge_into ~info:(infof "update: multi %d" i) m ~into:t + >>= merge_exn "update: multi") + in + let read t = + read + (fun i -> S.get t (k i)) + (fun i -> check S.contents_t (Fmt.str "update: multi %d" i) (v i)) + in + S.set_exn t1 ~info:(infof "update") (k 0) (v 0) >>= fun () -> + perform (write t1 1 10 @ write t2 2 10) >>= fun () -> + perform (read t1 10) >>= fun () -> B.Repo.close repo + in + run x test + + let pp_write_error = Irmin.Type.pp S.write_error_t + let tree_t = testable S.tree_t + + let test_with_tree x () = + let test repo = + let* t = S.main repo in + let update ?retries key strategy r w = + S.with_tree t ?retries ~info:(infof "with-tree") ~strategy key (fun _ -> + let+ v = Lwt_mvar.take r in + Some (S.Tree.of_contents v)) + >>= Lwt_mvar.put w + in + let check_ok = function + | Ok () -> () + | Error e -> Alcotest.failf "%a" pp_write_error e + in + let check_test e = function + | Error (`Test_was e') -> + Alcotest.(check (option tree_t)) "test-was" e e' + | Ok () -> Alcotest.fail "error expected" + | Error e -> + Alcotest.failf "an other error was expected: %a" pp_write_error e + in + let check_conflict = function + | Error (`Conflict _) -> () + | Ok () -> Alcotest.fail "error expected" + | Error e -> + Alcotest.failf "an other error was expected: %a" pp_write_error e + in + let set () = + let rx = Lwt_mvar.create_empty () in + let wx = Lwt_mvar.create_empty () in + let ry = Lwt_mvar.create_empty () in + let wy = Lwt_mvar.create_empty () in + S.set_exn t ~info:(infof "init") [ "a" ] "0" >>= fun () -> + Lwt.join + [ + update [ "a" ] ~retries:0 `Set rx wx; + update [ "a" ] ~retries:0 `Set ry wy; + ( Lwt_mvar.put rx "1" >>= fun () -> + Lwt_mvar.take wx >|= check_ok >>= fun () -> + let* a = S.get t [ "a" ] in + Alcotest.(check string) "set x" "1" a; + Lwt_mvar.put ry "2" >>= fun () -> + Lwt_mvar.take wy >|= check_ok >>= fun () -> + let+ a = S.get t [ "a" ] in + Alcotest.(check string) "set y" "2" a ); + ] + in + let test_and_set () = + let rx = Lwt_mvar.create_empty () in + let wx = Lwt_mvar.create_empty () in + let ry = Lwt_mvar.create_empty () in + let wy = Lwt_mvar.create_empty () in + let rz = Lwt_mvar.create_empty () in + let wz = Lwt_mvar.create_empty () in + S.set_exn t ~info:(infof "init") [ "a" ] "0" >>= fun () -> + Lwt.join + [ + update [ "a" ] ~retries:0 `Test_and_set rx wx; + update [ "a" ] ~retries:0 `Test_and_set ry wy; + update [ "a" ] ~retries:1 `Test_and_set rz wz; + ( Lwt_mvar.put rx "1" >>= fun () -> + Lwt_mvar.take wx >|= check_ok >>= fun () -> + let* a = S.get t [ "a" ] in + Alcotest.(check string) "test-and-set x" "1" a; + Lwt_mvar.put ry "2" >>= fun () -> + let* e = Lwt_mvar.take wy in + check_test (Some (S.Tree.of_contents "1")) e; + let* a = S.get t [ "a" ] in + Alcotest.(check string) "test-and-set y" "1" a; + Lwt_mvar.put rz "3" >>= fun () -> + (* there's a conflict, the transaction is restarted so need to feed a + new value *) + Lwt_mvar.put rz "4" >>= fun () -> + Lwt_mvar.take wz >|= check_ok >>= fun () -> + let+ a = S.get t [ "a" ] in + Alcotest.(check string) "test-and-set z" "4" a ); + ] + in + let merge () = + let rx = Lwt_mvar.create_empty () in + let wx = Lwt_mvar.create_empty () in + let ry = Lwt_mvar.create_empty () in + let wy = Lwt_mvar.create_empty () in + let rz = Lwt_mvar.create_empty () in + let wz = Lwt_mvar.create_empty () in + S.set_exn t ~info:(infof "init") [ "a" ] "0" >>= fun () -> + Lwt.join + [ + update [ "a" ] ~retries:0 `Merge rx wx; + update [ "a" ] ~retries:0 `Merge ry wy; + update [ "a" ] ~retries:1 `Merge rz wz; + ( Lwt_mvar.put rx "1" >>= fun () -> + Lwt_mvar.take wx >|= check_ok >>= fun () -> + let* a = S.get t [ "a" ] in + Alcotest.(check string) "merge x" "1" a; + Lwt_mvar.put ry "2" >>= fun () -> + Lwt_mvar.take wy >|= check_conflict >>= fun () -> + let* a = S.get t [ "a" ] in + Alcotest.(check string) "merge y" a "1"; + Lwt_mvar.put rz "3" >>= fun () -> + (* there's a conflict, the transaction is restarted so need to feed a + new value *) + Lwt_mvar.put rz "4" >>= fun () -> + Lwt_mvar.take wz >|= check_ok >>= fun () -> + let+ a = S.get t [ "a" ] in + Alcotest.(check string) "merge z" a "4" ); + ] + in + set () >>= test_and_set >>= merge >>= fun () -> B.Repo.close repo + in + run x test + + let test_concurrent_head_updates x () = + let test repo = + let k i = [ "a"; "b"; "c"; string_of_int i ] in + let v i = Fmt.str "X%d" i in + let* t1 = S.main repo in + let* t2 = S.main repo in + let retry d fn = + let rec aux i = + fn () >>= function + | true -> + [%log.debug "%d: ok!" d]; + Lwt.return_unit + | false -> + [%log.debug "%d: conflict, retrying (%d)." d i]; + aux (i + 1) + in + aux 1 + in + let write t n = + write (fun i -> + retry i (fun () -> + let* test = S.Head.find t in + let tag = Fmt.str "tmp-%d-%d" n i in + let* m = S.clone ~src:t ~dst:tag in + S.set_exn m ~info:(infof "update") (k i) (v i) >>= fun () -> + let* set = S.Head.find m in + Lwt.pause () >>= fun () -> S.Head.test_and_set t ~test ~set)) + in + let read t = + read + (fun i -> S.get t (k i)) + (fun i -> check S.contents_t (Fmt.str "update: multi %d" i) (v i)) + in + S.set_exn t1 ~info:(infof "update") (k 0) (v 0) >>= fun () -> + perform (write t1 1 5 @ write t2 2 5) >>= fun () -> + perform (read t1 5) >>= fun () -> B.Repo.close repo + in + run x test + + let test_shallow_objects x () = + let test repo = + (* NOTE: A store of type `Irmin.Generic_key.S` does not currently expose + functions for building nodes / commits with non-existent children, due to + the need to have _keys_ for all store pointers. + + A future version of this API may support such operations (e.g. for + constructing Merkle proofs), but until then we must synthesise test keys + by adding test values to the correponding backend stores directly. *) + let contents (s : string) : S.contents_key Lwt.t = + with_contents repo (fun c -> B.Contents.add c s) + in + let node (s : string) : S.node_key Lwt.t = + with_node repo (fun n -> + let* contents = contents s in + let node = B.Node.Val.(add (empty ())) s (normal contents) in + B.Node.add n node) + in + let commit (s : string) : S.commit_key Lwt.t = + with_commit repo (fun c -> + let* node = node s in + let commit = B.Commit.Val.v ~info:(info "") ~node ~parents:[] in + B.Commit.add c commit) + in + let* foo_k = node "foo" in + let* bar_k = node "bar" in + let tree_1 = S.Tree.shallow repo (`Node foo_k) in + let tree_2 = S.Tree.shallow repo (`Node bar_k) in + let* node_3 = + let+ contents_foo = contents "foo" in + S.Backend.Node.Val.of_list + [ + ("foo", `Contents (contents_foo, S.Metadata.default)); + ("bar", `Node bar_k); + ] + in + let tree_3 = S.Tree.of_node (S.of_backend_node repo node_3) in + let* _ = + S.Backend.Repo.batch repo (fun c n _ -> S.save_tree repo c n tree_3) + in + let key_3 = get_node_key (Option.get (S.Tree.key tree_3)) in + let info () = info "shallow" in + let* t = S.main repo in + S.set_tree_exn t [ "1" ] tree_1 ~info >>= fun () -> + S.set_tree_exn t [ "2" ] tree_2 ~info >>= fun () -> + let* h = S.Head.get t in + let* commit_v = + let+ commit_foo = commit "foo" in + S.Backend.Commit.Val.v ~info:(info ()) ~node:key_3 + ~parents:[ S.Commit.key h; commit_foo ] + in + let* commit_key = with_commit repo (fun c -> B.Commit.add c commit_v) in + let commit = S.of_backend_commit repo commit_key commit_v in + S.set_tree_exn t [ "3" ] ~parents:[ commit ] tree_3 ~info >>= fun () -> + let* t1 = S.find_tree t [ "1" ] in + Alcotest.(check (option tree_t)) "shallow tree" (Some tree_1) t1; + B.Repo.close repo + in + run x test + + let test_pre_hash_collisions x () = + let pre_hash_of ty = + let f = Irmin.Type.(pre_hash ty |> unstage) in + fun x -> + let buf = Buffer.create 0 in + f x (Buffer.add_string buf); + Buffer.contents buf + in + let rec add_entries acc = function + | 0 -> Lwt.return acc + | i -> + let s = string_of_int i in + let* acc = S.Tree.add acc [ s ] s in + add_entries acc (i - 1) + in + let equal_hash = Irmin.Type.(equal S.Hash.t |> unstage) in + let test create_tree repo = + let* tree = create_tree () in + let* c = S.Commit.v repo ~info:S.Info.empty ~parents:[] tree in + + let* node_b = + S.Tree.destruct tree + |> (function `Contents _ -> assert false | `Node n -> n) + |> S.to_backend_node + in + let node_ph = pre_hash_of S.Backend.Node.Val.t node_b in + let node_h = S.Backend.Node.Hash.hash node_b in + + let commit_b = S.to_backend_commit c in + let commit_ph = pre_hash_of S.Backend.Commit.Val.t commit_b in + let commit_h = S.Backend.Commit.Hash.hash commit_b in + + let* blob_k = + with_contents repo (fun t -> S.Backend.Contents.add t node_ph) + in + let blob_h = S.Backend.Contents.Key.to_hash blob_k in + if equal_hash node_h blob_h then + Alcotest.failf + "node pre-hash attack succeeded. pre-hash is \"%s\". backend node is \ + %a." + (String.escaped node_ph) + (Irmin.Type.pp S.Backend.Node.Val.t) + node_b; + + let* blob_k = + with_contents repo (fun t -> S.Backend.Contents.add t commit_ph) + in + let blob_h = S.Backend.Contents.Key.to_hash blob_k in + if equal_hash commit_h blob_h then + Alcotest.failf + "commit pre-hash attack succeeded. pre-hash is \"%s\". backend \ + commit is %a." + (String.escaped commit_ph) + (Irmin.Type.pp S.Backend.Commit.Val.t) + commit_b; + + S.Backend.Repo.close repo + in + (* Test collisions with the empty node (and its commit), *) + let* () = run x (test @@ fun () -> S.Tree.empty () |> Lwt.return) in + (* with a length one node, *) + run x (test @@ fun () -> add_entries (S.Tree.empty ()) 1) >>= fun () -> + (* and with a length >256 node (which is the threshold for unstable inodes + in irmin pack). *) + run x (test @@ fun () -> add_entries (S.Tree.empty ()) 260) +end + +let suite' l ?(prefix = "") (_, x) = + let (module S) = Suite.store_generic_key x in + let module T = Make (S) in + (prefix ^ x.name, l) + +let when_ b x = if b then x else [] + +let suite sleep (speed, x) = + let (module S) = Suite.store_generic_key x in + let module Zzz = struct + let sleep = sleep + end in + let module T = Make (S) in + let module T_graph = Store_graph.Make (S) in + let module T_watch = Store_watch.Make (Log) (Zzz) (S) in + let with_tree_enabled = + (* Disabled for flakiness. See https://github.com/mirage/irmin/issues/1090. *) + not + (List.mem ~equal:String.equal (Suite.name x) + [ + "FS"; + "FS.UNIX"; + "GIT"; + "GIT.UNIX"; + "HTTP.FS"; + "HTTP.FS.UNIX"; + "HTTP.GIT"; + "HTTP.GIT.UNIX"; + ]) + in + suite' + ([ + ("High-level operations on trees", speed, T.test_trees x); + ("Basic operations on contents", speed, T.test_contents x); + ("Basic operations on nodes", speed, T.test_nodes x); + ("Basic operations on commits", speed, T.test_commits x); + ("Basic operations on branches", speed, T.test_branches x); + ("Hash operations on trees", speed, T.test_tree_hashes x); + ("Basic merge operations", speed, T.test_simple_merges x); + ("Test merges on tree updates", speed, T.test_merge_outdated_tree x); + ("Tree caches and hashconsing", speed, T.test_tree_caches x); + ("Tree proofs", speed, T.test_proofs x); + ("Complex histories", speed, T.test_history x); + ("Empty stores", speed, T.test_empty x); + ("Backend node manipulation", speed, T.test_backend_nodes x); + ("High-level store operations", speed, T.test_stores x); + ("High-level atomic store operations", speed, T.test_atomic x); + ("High-level store merges", speed, T.test_merge x); + ("Unrelated merges", speed, T.test_merge_unrelated x); + ("Low-level concurrency", speed, T.test_concurrent_low x); + ("Concurrent updates", speed, T.test_concurrent_updates x); + ("Concurrent head updates", speed, T.test_concurrent_head_updates x); + ("Concurrent merges", speed, T.test_concurrent_merges x); + ("Shallow objects", speed, T.test_shallow_objects x); + ("Closure with disconnected commits", speed, T.test_closure x); + ("Prehash collisions", speed, T.test_pre_hash_collisions x); + ] + @ when_ x.import_supported + [ + ("Basic operations on slices", speed, T.test_slice x); + ("High-level store synchronisation", speed, T.test_sync x); + ] + @ when_ with_tree_enabled + [ ("with_tree strategies", speed, T.test_with_tree x) ] + @ List.map (fun (n, test) -> ("Graph." ^ n, speed, test x)) T_graph.tests + @ List.map (fun (n, test) -> ("Watch." ^ n, speed, test x)) T_watch.tests) + (speed, x) + +let slow_suite (speed, x) = + let (module S) = Suite.store_generic_key x in + let module T = Make (S) in + suite' ~prefix:"SLOW_" + [ + ("Commit wide node", speed, T.test_commit_wide_node x); + ("Wide nodes", `Slow, T.test_wide_nodes x); + ] + (speed, x) + +let run name ?(slow = false) ?random_seed ~sleep ~misc tl = + let () = + match random_seed with + | Some x -> Random.init x + | None -> Random.self_init () + in + Printexc.record_backtrace true; + (* Ensure that failures occuring in async lwt threads are raised. *) + (Lwt.async_exception_hook := fun exn -> raise exn); + let tl1 = List.map (suite sleep) tl in + let tl1 = if slow then tl1 @ List.map slow_suite tl else tl1 in + Alcotest_lwt.run ~__FILE__ name (misc @ tl1) diff --git a/irmin/test/helpers/store.mli b/irmin/test/helpers/store.mli new file mode 100644 index 000000000000..57aeeb89dc4b --- /dev/null +++ b/irmin/test/helpers/store.mli @@ -0,0 +1,24 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +val run : + string -> + ?slow:bool -> + ?random_seed:int -> + sleep:(float -> unit Lwt.t) -> + misc:unit Alcotest_lwt.test list -> + (Alcotest.speed_level * Common.t) list -> + unit Lwt.t diff --git a/irmin/test/helpers/store_graph.ml b/irmin/test/helpers/store_graph.ml new file mode 100644 index 000000000000..2d576ea5d666 --- /dev/null +++ b/irmin/test/helpers/store_graph.ml @@ -0,0 +1,209 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Common + +module Make (S : Generic_key) = struct + include Common.Make_helpers (S) + + let test_iter x () = + let test repo = + let pp_id = Irmin.Type.pp S.Tree.kinded_key_t in + let eq_id = Irmin.Type.(unstage (equal S.Tree.kinded_key_t)) in + let mem k ls = List.exists (fun k' -> eq_id k k') ls in + let visited = ref [] in + let skipped = ref [] in + let rev_order oldest k = + if !visited = [] && not (eq_id k oldest) then + Alcotest.fail "traversal should start with oldest node" + in + let in_order oldest k = + if !visited = [] && eq_id k oldest then + Alcotest.fail "traversal shouldn't start with oldest node" + in + let node k = + if mem (`Node k) !visited then + Alcotest.failf "node %a visited twice" (Irmin.Type.pp B.Node.Key.t) k; + visited := `Node k :: !visited; + Lwt.return_unit + in + let contents ?order k = + let e = `Contents (k, S.Metadata.default) in + if mem e !visited then + Alcotest.failf "contents %a visited twice" + (Irmin.Type.pp B.Contents.Key.t) + k; + (match order with None -> () | Some f -> f e); + visited := e :: !visited; + Lwt.return_unit + in + let test_rev_order ~nodes ~max = + let oldest = List.hd nodes in + let contents = contents ~order:(rev_order oldest) in + let+ () = + Graph.iter (g repo) ~min:[] ~max ~node ~contents ~rev:true () + in + List.iter + (fun k -> + if not (mem k !visited) then + Alcotest.failf "%a should be visited" + (Irmin.Type.pp S.Tree.kinded_key_t) + k) + nodes + in + let test_in_order ~nodes ~max = + let oldest = List.hd nodes in + let contents = contents ~order:(in_order oldest) in + let+ () = + Graph.iter (g repo) ~min:[] ~max ~node ~contents ~rev:false () + in + List.iter + (fun k -> + if not (mem k !visited) then + Alcotest.failf "%a should be visited" pp_id k) + nodes + in + let test_skip ~max ~to_skip ~not_visited = + let skip_node k = + if mem (`Node k) to_skip then ( + skipped := `Node k :: !skipped; + Lwt.return_true) + else Lwt.return_false + in + let+ () = + Graph.iter (g repo) ~min:[] ~max ~node ~contents ~skip_node ~rev:false + () + in + List.iter + (fun k -> + if mem k !visited || not (mem k !skipped) then + Alcotest.failf "%a should be skipped" pp_id k) + to_skip; + List.iter + (fun k -> + if mem k !visited || mem k !skipped then + Alcotest.failf "%a should not be skipped nor visited" pp_id k) + not_visited + in + let test_min_max ~nodes ~min ~max ~not_visited = + Graph.iter (g repo) ~min ~max ~node ~contents ~rev:false () + >|= fun () -> + List.iter + (fun k -> + if mem k not_visited && mem k !visited then + Alcotest.failf "%a should not be visited" pp_id k; + if (not (mem k not_visited)) && not (mem k !visited) then + Alcotest.failf "%a should not be visited" pp_id k) + nodes + in + let test1 () = + let* foo = with_contents repo (fun c -> B.Contents.add c "foo") in + let foo_k = (foo, S.Metadata.default) in + let* k1 = with_node repo (fun g -> Graph.v g [ ("b", normal foo) ]) in + let* k2 = with_node repo (fun g -> Graph.v g [ ("a", `Node k1) ]) in + let* k3 = with_node repo (fun g -> Graph.v g [ ("c", `Node k1) ]) in + let nodes = [ `Contents foo_k; `Node k1; `Node k2; `Node k3 ] in + visited := []; + test_rev_order ~nodes ~max:[ k2; k3 ] >>= fun () -> + visited := []; + test_in_order ~nodes ~max:[ k2; k3 ] >>= fun () -> + visited := []; + skipped := []; + test_skip ~max:[ k2; k3 ] ~to_skip:[ `Node k1 ] ~not_visited:[] + >>= fun () -> + visited := []; + let* () = + test_min_max ~nodes ~min:[ k1 ] ~max:[ k2 ] + ~not_visited:[ `Contents foo_k; `Node k3 ] + in + visited := []; + test_min_max ~nodes ~min:[ k2; k3 ] ~max:[ k2; k3 ] + ~not_visited:[ `Contents foo_k; `Node k1 ] + in + let test2 () = + (* Graph.iter requires a node as max, we cannot test a graph with only + contents. *) + let* foo = with_contents repo (fun c -> B.Contents.add c "foo") in + let foo_k = (foo, S.Metadata.default) in + let* k1 = with_node repo (fun g -> Graph.v g [ ("b", normal foo) ]) in + visited := []; + test_rev_order ~nodes:[ `Contents foo_k; `Node k1 ] ~max:[ k1 ] + >>= fun () -> + visited := []; + skipped := []; + test_skip ~max:[ k1 ] + ~to_skip:[ `Node k1 ] + ~not_visited:[ `Contents foo_k ] + in + let test3 () = + let* foo = with_contents repo (fun c -> B.Contents.add c "foo") in + let foo_k = (foo, S.Metadata.default) in + let* kb1 = with_node repo (fun g -> Graph.v g [ ("b1", normal foo) ]) in + let* ka1 = with_node repo (fun g -> Graph.v g [ ("a1", `Node kb1) ]) in + let* ka2 = with_node repo (fun g -> Graph.v g [ ("a2", `Node kb1) ]) in + let* kb2 = with_node repo (fun g -> Graph.v g [ ("b2", normal foo) ]) in + let* kc = + with_node repo (fun g -> + Graph.v g + [ ("c1", `Node ka1); ("c2", `Node ka2); ("c3", `Node kb2) ]) + in + let nodes = + [ + `Contents foo_k; + `Node kb1; + `Node ka1; + `Node ka2; + `Node kb2; + `Node kc; + ] + in + visited := []; + test_rev_order ~nodes ~max:[ kc ] >>= fun () -> + visited := []; + test_in_order ~nodes ~max:[ kc ] >>= fun () -> + visited := []; + skipped := []; + let* () = + test_skip ~max:[ kc ] + ~to_skip:[ `Node ka1; `Node ka2 ] + ~not_visited:[ `Node kb1 ] + in + visited := []; + skipped := []; + let* () = + test_skip ~max:[ kc ] + ~to_skip:[ `Node ka1; `Node ka2; `Node kb2 ] + ~not_visited:[ `Node kb1; `Contents foo_k ] + in + visited := []; + let* () = + test_min_max ~nodes ~min:[ kb1 ] ~max:[ ka1 ] + ~not_visited:[ `Contents foo_k; `Node ka2; `Node kb2; `Node kc ] + in + visited := []; + test_min_max ~nodes ~min:[ kc ] ~max:[ kc ] + ~not_visited: + [ `Contents foo_k; `Node kb1; `Node ka1; `Node ka2; `Node kb2 ] + in + test1 () >>= fun () -> + test2 () >>= fun () -> + test3 () >>= fun () -> B.Repo.close repo + in + run x test + + let tests = [ ("Iter", test_iter) ] +end diff --git a/irmin/test/helpers/store_graph.mli b/irmin/test/helpers/store_graph.mli new file mode 100644 index 000000000000..5e5cf9415ee4 --- /dev/null +++ b/irmin/test/helpers/store_graph.mli @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Make : Common.Store_tests diff --git a/irmin/test/helpers/store_watch.ml b/irmin/test/helpers/store_watch.ml new file mode 100644 index 000000000000..5b19ebed0d2a --- /dev/null +++ b/irmin/test/helpers/store_watch.ml @@ -0,0 +1,379 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Common + +module type Sleep = sig + val sleep : float -> unit Lwt.t +end + +module Make (Log : Logs.LOG) (Zzz : Sleep) (S : Generic_key) = struct + include Common.Make_helpers (S) + + let sleep ?(sleep_t = 0.01) () = + let sleep_t = min sleep_t 1. in + Lwt.pause () >>= fun () -> Zzz.sleep sleep_t + + let now_s () = Mtime.span_to_s (Mtime_clock.elapsed ()) + + (* Re-apply [f] at intervals of [sleep_t] while [f] raises exceptions and + [while_ ()] holds. *) + let retry ?(timeout = 15.) ?(sleep_t = 0.) ~while_ fn = + let sleep_t = max sleep_t 0.001 in + let t = now_s () in + let str i = Fmt.str "%d, %.3fs" i (now_s () -. t) in + let rec aux i = + if now_s () -. t > timeout || not (while_ ()) then fn (str i); + try + fn (str i); + Lwt.return_unit + with ex -> + [%log.debug "retry ex: %s" (Printexc.to_string ex)]; + let sleep_t = sleep_t *. (1. +. (float i ** 2.)) in + sleep ~sleep_t () >>= fun () -> + [%log.debug "Test.retry %s" (str i)]; + aux (i + 1) + in + aux 0 + + let test_watch_exn x () = + let test repo = + let* t = S.main repo in + let* h = S.Head.find t in + let key = [ "a" ] in + let v1 = "bar" in + let v2 = "foo" in + let r = ref 0 in + let eq = Irmin.Type.(unstage (equal (Irmin.Diff.t (S.commit_t repo)))) in + let old_head = ref h in + let check x = + let+ h2 = S.Head.get t in + match !old_head with + | None -> if eq (`Added h2) x then incr r + | Some h -> if eq (`Updated (h, h2)) x then incr r + in + let* u = + S.watch ?init:h t (fun v -> check v >|= fun () -> failwith "test") + in + let* v = + S.watch ?init:h t (fun v -> check v >>= fun () -> Lwt.fail_with "test") + in + let* w = S.watch ?init:h t (fun v -> check v) in + S.set_exn t ~info:(infof "update") key v1 >>= fun () -> + let* () = + retry + ~while_:(fun () -> !r < 3) + (fun n -> Alcotest.(check int) ("watch 1 " ^ n) 3 !r) + in + let* h = S.Head.find t in + old_head := h; + S.set_exn t ~info:(infof "update") key v2 >>= fun () -> + let* () = + retry + ~while_:(fun () -> !r < 6) + (fun n -> Alcotest.(check int) ("watch 2 " ^ n) 6 !r) + in + S.unwatch u >>= fun () -> + S.unwatch v >>= fun () -> + S.unwatch w >>= fun () -> + let* h = S.Head.get t in + old_head := Some h; + let* u = + S.watch_key ~init:h t key (fun _ -> + incr r; + failwith "test") + in + let* v = + S.watch_key ~init:h t key (fun _ -> + incr r; + Lwt.fail_with "test") + in + let* w = + S.watch_key ~init:h t key (fun _ -> + incr r; + Lwt.return_unit) + in + S.set_exn t ~info:(infof "update") key v1 >>= fun () -> + let* () = + retry + ~while_:(fun () -> !r < 9) + (fun n -> Alcotest.(check int) ("watch 3 " ^ n) 9 !r) + in + S.set_exn t ~info:(infof "update") key v2 >>= fun () -> + let* () = + retry + ~while_:(fun () -> !r < 12) + (fun n -> Alcotest.(check int) ("watch 4 " ^ n) 12 !r) + in + S.unwatch u >>= fun () -> + S.unwatch v >>= fun () -> + S.unwatch w >>= fun () -> + Alcotest.(check unit) "ok!" () (); + B.Repo.close repo + in + run x test + + let test_watches x () = + let pp_w ppf (p, w) = Fmt.pf ppf "%d/%d" p w in + let pp_s ppf = function + | None -> Fmt.string ppf "*" + | Some w -> pp_w ppf (w ()) + in + let check_workers msg p w = + match x.stats with + | None -> Lwt.return_unit + | Some stats -> + retry + ~while_:(fun _ -> true) + (fun s -> + let got = stats () in + let exp = (p, w) in + let msg = Fmt.str "workers: %s %a (%s)" msg pp_w got s in + if got = exp then line msg + else ( + [%log.debug + "check-worker: expected %a, got %a" pp_w exp pp_w got]; + Alcotest.failf "%s: %a / %a" msg pp_w got pp_w exp)) + in + let module State = struct + type t = { + mutable adds : int; + mutable updates : int; + mutable removes : int; + } + + let pp ppf { adds; updates; removes } = + Fmt.pf ppf "{ adds=%d; updates=%d; removes=%d }" adds updates removes + + let empty () = { adds = 0; updates = 0; removes = 0 } + + let add t = + [%log.debug "add %a" pp t]; + t.adds <- t.adds + 1 + + let update t = + [%log.debug "update %a" pp t]; + t.updates <- t.updates + 1 + + let remove t = + [%log.debug "remove %a" pp t]; + t.removes <- t.removes + 1 + + let pretty ppf t = Fmt.pf ppf "%d/%d/%d" t.adds t.updates t.removes + let xpp ppf (a, u, r) = Fmt.pf ppf "%d/%d/%d" a u r + let xadd (a, u, r) = (a + 1, u, r) + let xupdate (a, u, r) = (a, u + 1, r) + let xremove (a, u, r) = (a, u, r + 1) + + let less_than a b = + a.adds <= b.adds + && a.updates <= b.updates + && a.removes <= b.removes + && not (a = b) + + let check ?sleep_t msg (p, w) (a_adds, a_updates, a_removes) b = + let a = { adds = a_adds; updates = a_updates; removes = a_removes } in + check_workers msg p w >>= fun () -> + retry ?sleep_t + ~while_:(fun () -> less_than b a (* While [b] converges toward [a] *)) + (fun s -> + let msg = Fmt.str "state: %s (%s)" msg s in + if a = b then line msg + else Alcotest.failf "%s: %a / %a" msg pp a pp b) + + let process ?sleep_t t head = + let* () = + match sleep_t with None -> Lwt.return_unit | Some s -> Zzz.sleep s + in + let () = + match head with + | `Added _ -> add t + | `Updated _ -> update t + | `Removed _ -> remove t + in + Lwt.return_unit + + let apply msg state kind fn ?(first = false) on s n = + let msg mode n w s = + let kind = + match kind with + | `Add -> "add" + | `Update -> "update" + | `Remove -> "remove" + in + let mode = + match mode with `Pre -> "[pre-condition]" | `Post -> "" + in + Fmt.str "%s %s %s %d on=%b expected=%a:%a current=%a:%a" mode msg kind + n on xpp s pp_w w pretty state pp_s x.stats + in + let check mode n w s = check (msg mode n w s) w s state in + let incr = + match kind with + | `Add -> xadd + | `Update -> xupdate + | `Remove -> xremove + in + let rec aux pre = function + | 0 -> Lwt.return_unit + | i -> + let pre_w = + if on then (1, if i = n && first then 0 else 1) else (0, 0) + in + let post_w = if on then (1, 1) else (0, 0) in + let post = if on then incr pre else pre in + (* check pre-condition *) + check `Pre (n - i) pre_w pre >>= fun () -> + [%log.debug "[waiting for] %s" (msg `Post (n - i) post_w post)]; + fn (n - i) >>= fun () -> + (* check post-condition *) + check `Post (n - i) post_w post >>= fun () -> aux post (i - 1) + in + aux s n + end in + let test repo1 = + let* t1 = S.main repo1 in + let* repo = S.Repo.v x.config in + let* t2 = S.main repo in + [%log.debug "WATCH"]; + let state = State.empty () in + let sleep_t = 0.02 in + let process = State.process ~sleep_t state in + let stops_0 = ref [] in + let stops_1 = ref [] in + let rec watch = function + | 0 -> Lwt.return_unit + | n -> + let t = if n mod 2 = 0 then t1 else t2 in + let* s = S.watch t process in + if n mod 2 = 0 then stops_0 := s :: !stops_0 + else stops_1 := s :: !stops_1; + watch (n - 1) + in + let v1 = "X1" in + let v2 = "X2" in + S.set_exn t1 ~info:(infof "update") [ "a"; "b" ] v1 >>= fun () -> + S.Branch.remove repo1 S.Branch.main >>= fun () -> + State.check "init" (0, 0) (0, 0, 0) state >>= fun () -> + watch 100 >>= fun () -> + State.check "watches on" (1, 0) (0, 0, 0) state >>= fun () -> + S.set_exn t1 ~info:(infof "update") [ "a"; "b" ] v1 >>= fun () -> + State.check "watches adds" (1, 1) (100, 0, 0) state >>= fun () -> + S.set_exn t2 ~info:(infof "update") [ "a"; "c" ] v1 >>= fun () -> + State.check "watches updates" (1, 1) (100, 100, 0) state >>= fun () -> + S.Branch.remove repo S.Branch.main >>= fun () -> + State.check "watches removes" (1, 1) (100, 100, 100) state >>= fun () -> + Lwt_list.iter_s (fun f -> S.unwatch f) !stops_0 >>= fun () -> + S.set_exn t2 ~info:(infof "update") [ "a" ] v1 >>= fun () -> + State.check "watches half off" (1, 1) (150, 100, 100) state >>= fun () -> + Lwt_list.iter_s (fun f -> S.unwatch f) !stops_1 >>= fun () -> + S.set_exn t1 ~info:(infof "update") [ "a" ] v2 >>= fun () -> + State.check "watches off" (0, 0) (150, 100, 100) state >>= fun () -> + [%log.debug "WATCH-ALL"]; + let state = State.empty () in + let* head = r1 ~repo in + let add = + State.apply "branch-watch-all" state `Add (fun n -> + let tag = Fmt.str "t%d" n in + S.Branch.set repo tag head) + in + let remove = + State.apply "branch-watch-all" state `Remove (fun n -> + let tag = Fmt.str "t%d" n in + S.Branch.remove repo tag) + in + let* main = S.Branch.get repo "main" in + let* u = + S.Branch.watch_all + ~init:[ ("main", main) ] + repo + (fun _ -> State.process state) + in + add true (0, 0, 0) 10 ~first:true >>= fun () -> + remove true (10, 0, 0) 5 >>= fun () -> + S.unwatch u >>= fun () -> + add false (10, 0, 5) 4 >>= fun () -> + remove false (10, 0, 5) 4 >>= fun () -> + [%log.debug "WATCH-KEY"]; + let state = State.empty () in + let path1 = [ "a"; "b"; "c" ] in + let path2 = [ "a"; "d" ] in + let path3 = [ "a"; "b"; "d" ] in + let add = + State.apply "branch-key" state `Add (fun _ -> + let v = "" in + S.set_exn t1 ~info:(infof "set1") path1 v >>= fun () -> + S.set_exn t1 ~info:(infof "set2") path2 v >>= fun () -> + S.set_exn t1 ~info:(infof "set3") path3 v >>= fun () -> + Lwt.return_unit) + in + let update = + State.apply "branch-key" state `Update (fun n -> + let v = string_of_int n in + S.set_exn t2 ~info:(infof "update1") path1 v >>= fun () -> + S.set_exn t2 ~info:(infof "update2") path2 v >>= fun () -> + S.set_exn t2 ~info:(infof "update3") path3 v >>= fun () -> + Lwt.return_unit) + in + let remove = + State.apply "branch-key" state `Remove (fun _ -> + S.remove_exn t1 ~info:(infof "remove1") path1 >>= fun () -> + S.remove_exn t1 ~info:(infof "remove2") path2 >>= fun () -> + S.remove_exn t1 ~info:(infof "remove3") path3 >>= fun () -> + Lwt.return_unit) + in + S.remove_exn t1 ~info:(infof "clean") [] >>= fun () -> + let* init = S.Head.get t1 in + let* u = S.watch_key t1 ~init path1 (State.process state) in + add true (0, 0, 0) 1 ~first:true >>= fun () -> + update true (1, 0, 0) 10 >>= fun () -> + remove true (1, 10, 0) 1 >>= fun () -> + S.unwatch u >>= fun () -> + add false (1, 10, 1) 3 >>= fun () -> + update false (1, 10, 1) 5 >>= fun () -> + remove false (1, 10, 1) 4 >>= fun () -> + [%log.debug "WATCH-MORE"]; + let state = State.empty () in + let update = + State.apply "watch-more" state `Update (fun n -> + let v = string_of_int n in + let path1 = [ "a"; "b"; "c"; string_of_int n; "1" ] in + let path2 = [ "a"; "x"; "c"; string_of_int n; "1" ] in + let path3 = [ "a"; "y"; "c"; string_of_int n; "1" ] in + S.set_exn t2 ~info:(infof "update1") path1 v >>= fun () -> + S.set_exn t2 ~info:(infof "update2") path2 v >>= fun () -> + S.set_exn t2 ~info:(infof "update3") path3 v >>= fun () -> + Lwt.return_unit) + in + S.remove_exn t1 ~info:(infof "remove") [ "a" ] >>= fun () -> + S.set_exn t1 ~info:(infof "prepare") [ "a"; "b"; "c" ] "" >>= fun () -> + let* h = S.Head.get t1 in + let* u = S.watch_key t2 ~init:h [ "a"; "b" ] (State.process state) in + update true (0, 0, 0) 10 ~first:true >>= fun () -> + S.unwatch u >>= fun () -> + update false (0, 10, 0) 10 >>= fun () -> + B.Repo.close repo >>= fun () -> B.Repo.close repo1 + in + run x test + + let tests = + (* [test_watches] has been disabled for being flaky. + TODO: work out why, fix it, and re-enable it. + See https://github.com/mirage/irmin/issues/1447. *) + let _ = ("Basic operations", test_watches) in + [ ("Callbacks and exceptions", test_watch_exn) ] +end diff --git a/irmin/test/helpers/store_watch.mli b/irmin/test/helpers/store_watch.mli new file mode 100644 index 000000000000..52f253c7bb3c --- /dev/null +++ b/irmin/test/helpers/store_watch.mli @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Make (_ : Logs.LOG) (_ : Common.Sleep) : Common.Store_tests -- GitLab From 65d87156968e585dd709936dde5c5436be0f516e Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Thu, 4 Apr 2024 16:35:18 +0200 Subject: [PATCH 2/3] manifest: add irmin_test_helpers lib --- irmin/test/dune | 1 + irmin/test/helpers/dune | 22 ++++++++++++++++++++++ manifest/product_octez.ml | 10 ++++++++++ opam/octez-internal-libs.opam | 1 + opam/tezos_internal_irmin_tests.opam | 1 + 5 files changed, 35 insertions(+) create mode 100644 irmin/test/helpers/dune diff --git a/irmin/test/dune b/irmin/test/dune index 24ed7b3c5e8d..0886c7525dd1 100644 --- a/irmin/test/dune +++ b/irmin/test/dune @@ -12,6 +12,7 @@ octez-libs.tezos-context.disk octez-libs.tezos-context.memory octez-libs.tezos-context.encoding + octez-internal-libs.irmin_test_helpers octez-libs.stdlib-unix octez-libs.test-helpers tezt) diff --git a/irmin/test/helpers/dune b/irmin/test/helpers/dune new file mode 100644 index 000000000000..723677771aab --- /dev/null +++ b/irmin/test/helpers/dune @@ -0,0 +1,22 @@ +; This file was automatically generated, do not edit. +; Edit file manifest/main.ml instead. + +(library + (name irmin_test_helpers) + (public_name octez-internal-libs.irmin_test_helpers) + (instrumentation (backend bisect_ppx)) + (libraries + octez-alcotezt + astring + fmt + octez-internal-libs.irmin + jsonm + logs + lwt + mtime + mtime.clock.os) + (preprocess (pps octez-internal-libs.ppx_irmin.internal)) + (flags + (:standard) + -w -66-68 + -open Octez_alcotezt)) diff --git a/manifest/product_octez.ml b/manifest/product_octez.ml index f072ade6a0db..cd8f42175ebf 100644 --- a/manifest/product_octez.ml +++ b/manifest/product_octez.ml @@ -1840,6 +1840,15 @@ let irmin_pack_unix = ~preprocess:[pps ppx_irmin_internal] ~flags:(Flags.standard ~disable_warnings:[66; 68] ()) +let irmin_test_helpers = + octez_internal_lib + "irmin_test_helpers" + ~path:"irmin/test/helpers" + ~deps: + [alcotezt; astring; fmt; irmin; jsonm; logs; lwt; mtime; mtime_clock_os] + ~preprocess:[pps ppx_irmin_internal] + ~flags:(Flags.standard ~disable_warnings:[66; 68] ()) + let octez_clic = octez_lib "clic" @@ -2722,6 +2731,7 @@ let _irmin_tests = octez_context_disk; octez_context_memory; octez_context_encoding; + irmin_test_helpers; octez_stdlib_unix |> open_; octez_test_helpers |> open_; tezt_lib |> open_ |> open_ ~m:"Base"; diff --git a/opam/octez-internal-libs.opam b/opam/octez-internal-libs.opam index 3d0f225cacf6..f9aef0829f06 100644 --- a/opam/octez-internal-libs.opam +++ b/opam/octez-internal-libs.opam @@ -35,6 +35,7 @@ depends: [ "cmdliner" { >= "1.1.0" } "checkseum" { != "0.5.0" } "rusage" + "octez-alcotezt" { = version } ] build: [ ["rm" "-r" "vendors" "contrib"] diff --git a/opam/tezos_internal_irmin_tests.opam b/opam/tezos_internal_irmin_tests.opam index eefda3cb7f92..cd3b934b946d 100644 --- a/opam/tezos_internal_irmin_tests.opam +++ b/opam/tezos_internal_irmin_tests.opam @@ -12,6 +12,7 @@ depends: [ "ocaml" { >= "4.14" } "tezt" { with-test & >= "4.0.0" & < "5.0.0" } "octez-libs" {with-test} + "octez-internal-libs" {with-test} ] build: [ ["rm" "-r" "vendors" "contrib"] -- GitLab From bdb57277330bbcf4945edcb08ce26feb61ab6d3a Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Fri, 5 Apr 2024 08:43:09 +0200 Subject: [PATCH 3/3] irmin: update readme --- irmin/README.md | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/irmin/README.md b/irmin/README.md index ab2ac95b99cd..e92f1c2cb3c6 100644 --- a/irmin/README.md +++ b/irmin/README.md @@ -11,7 +11,8 @@ itself is primarily developed and maintained by [contributors](https://github.com/mirage/irmin/graphs/contributors) from various organizations. -Like Irmin, beside the `test` directory, the code in this directory is under the +Like Irmin, beside the some files in the `test` directory, the code in this +directory is under the [ISC](https://github.com/mirage/irmin/blob/main/LICENSE.md) license. @@ -22,7 +23,9 @@ Like Irmin, beside the `test` directory, the code in this directory is under the | `irmin` | `./lib_irmin` | [`src/irmin`](https://github.com/mirage/irmin/tree/main/src/irmin) | | `irmin_pack` | `./lib_irmin_pack` | [`src/irmin-pack`](https://github.com/mirage/irmin/tree/main/src/irmin-pack) | | `ppx_irmin`\* | `./lib_ppx_irmin` | [`src/ppx_irmin`](https://github.com/mirage/irmin/tree/main/src/ppx_irmin) | -| `test`\* | `./test` | NA | +| `test`\* | `./test` | NA | +| `irmin_test_helpers` | `./test/helpers` | [`src/irmin-test`](https://github.com/mirage/irmin/tree/main/src/irmin-test) | + \*`ppx-irmin` is not directly used by Octez, but it is a dependency of `irmin` and `irmin-pack`. -- GitLab