From 00ee488c9e480412a0960507f79e7945dc3e8e44 Mon Sep 17 00:00:00 2001 From: Patrick Ferris Date: Sun, 5 Jun 2022 17:43:51 +0100 Subject: [PATCH 01/99] Convert Irmin from Lwt to direct-style with Eio --- src/irmin-test/common.ml | 99 +- src/irmin-test/dune | 5 +- src/irmin-test/irmin_test.mli | 18 +- src/irmin-test/store.ml | 1686 ++++++++--------- src/irmin-test/store.mli | 6 +- src/irmin-test/store_graph.ml | 72 +- src/irmin-test/store_watch.ml | 219 ++- src/irmin/append_only_intf.ml | 2 +- src/irmin/atomic_write.ml | 5 +- src/irmin/atomic_write_intf.ml | 19 +- src/irmin/backend.ml | 9 +- src/irmin/commit.ml | 72 +- src/irmin/commit_intf.ml | 23 +- src/irmin/content_addressable.ml | 18 +- src/irmin/content_addressable_intf.ml | 4 +- src/irmin/contents.ml | 7 +- src/irmin/dot.ml | 46 +- src/irmin/dot.mli | 2 +- src/irmin/dune | 2 +- src/irmin/import.ml | 7 - src/irmin/indexable.ml | 11 +- src/irmin/indexable_intf.ml | 6 +- src/irmin/irmin.ml | 14 +- src/irmin/lock.ml | 27 +- src/irmin/lock.mli | 2 +- src/irmin/mem/irmin_mem.ml | 48 +- src/irmin/merge.ml | 113 +- src/irmin/merge.mli | 26 +- src/irmin/node.ml | 74 +- src/irmin/node_intf.ml | 26 +- src/irmin/object_graph.ml | 62 +- src/irmin/object_graph_intf.ml | 20 +- src/irmin/proof.ml | 4 +- src/irmin/proof_intf.ml | 4 +- src/irmin/read_only_intf.ml | 4 +- src/irmin/remote.ml | 9 +- src/irmin/remote_intf.ml | 6 +- src/irmin/slice.ml | 23 +- src/irmin/slice_intf.ml | 6 +- src/irmin/storage.ml | 25 +- src/irmin/storage_intf.ml | 18 +- src/irmin/store.ml | 561 +++--- src/irmin/store_intf.ml | 253 ++- src/irmin/store_properties_intf.ml | 8 +- src/irmin/sync.ml | 142 +- src/irmin/sync_intf.ml | 16 +- src/irmin/tree.ml | 463 +++-- src/irmin/tree_intf.ml | 75 +- src/irmin/watch.ml | 88 +- src/irmin/watch_intf.ml | 22 +- test/irmin/dune | 4 +- test/irmin/generic-key/dune | 3 - .../generic-key/test_inlined_contents.ml | 15 +- test/irmin/generic-key/test_store_offset.ml | 16 +- test/irmin/test.ml | 10 +- test/irmin/test_conf.ml | 4 +- test/irmin/test_conf.mli | 2 +- test/irmin/test_hash.ml | 2 +- test/irmin/test_hash.mli | 2 +- test/irmin/test_tree.ml | 441 ++--- test/irmin/test_tree.mli | 2 +- 61 files changed, 2378 insertions(+), 2600 deletions(-) diff --git a/src/irmin-test/common.ml b/src/irmin-test/common.ml index 01436177bb..154cd781c9 100644 --- a/src/irmin-test/common.ml +++ b/src/irmin-test/common.ml @@ -29,7 +29,7 @@ let long_random_ascii_string = random_ascii_string 1024_000 let merge_exn msg x = match x with - | Ok x -> Lwt.return x + | Ok x -> x | Error (`Conflict m) -> Alcotest.failf "%s: %s" msg m open Astring @@ -73,8 +73,8 @@ 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; + init : config:Irmin.config -> unit; + clean : config:Irmin.config -> unit; config : Irmin.config; store : store; stats : (unit -> int * int) option; @@ -98,20 +98,19 @@ module Suite = struct | 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 + let repo = Store.Repo.v config in + let branches = Store.Repo.branches repo in + let () = List.iter (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 create ~name ?(init = fun ~config:_ -> ()) ?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 create_generic_key ~name ?(init = fun ~config:_ -> ()) ?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 } @@ -130,7 +129,7 @@ module Suite = struct end module type Store_tests = functor (S : Generic_key) -> sig - val tests : (string * (Suite.t -> unit -> unit Lwt.t)) list + val tests : (string * (Suite.t -> unit -> unit)) list end module Make_helpers (S : Generic_key) = struct @@ -173,50 +172,49 @@ module Make_helpers (S : Generic_key) = struct let b2 = "bar/toto" let n1 ~repo = - let* kv1 = kv1 ~repo in + let kv1 = kv1 ~repo in with_node repo (fun t -> Graph.v t [ ("x", normal kv1) ]) let n2 ~repo = - let* kn1 = n1 ~repo in + let kn1 = n1 ~repo in with_node repo (fun t -> Graph.v t [ ("b", `Node kn1) ]) let n3 ~repo = - let* kn2 = n2 ~repo in + 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 = + 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 + let kn2 = n2 ~repo in + match S.Tree.of_key repo (`Node kn2) with | 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 + let kn3 = n3 ~repo in + let kr1 = r1 ~repo in + match S.Tree.of_key repo (`Node kn3) with | 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 ignore_thunk_errors f = try f () with _ -> () let run (x : Suite.t) test = let repo_ptr = ref None in let config_ptr = ref None in - Lwt.catch - (fun () -> + try let module Conf = Irmin.Backend.Conf in let generate_random_root config = let id = Random.int 100 |> string_of_int in @@ -230,32 +228,32 @@ module Make_helpers (S : Generic_key) = struct 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 + let () = x.init ~config in + let repo = S.Repo.v config in repo_ptr := Some repo; - let* () = test repo in - let* () = + 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 -> + x.clean ~config + with exn -> (* [test] failed, attempt an errorless cleanup and forward the right backtrace to the user. *) let bt = Printexc.get_raw_backtrace () in - let* () = + let () = match !repo_ptr with | Some repo -> ignore_thunk_errors (fun () -> S.Repo.close repo) - | None -> Lwt.return_unit + | None -> () in - let+ () = + let () = match !config_ptr with | Some config -> ignore_thunk_errors (fun () -> x.clean ~config) - | None -> Lwt.return_unit + | None ->() in - Printexc.raise_with_backtrace exn bt) + Printexc.raise_with_backtrace exn bt end let filter_src src = @@ -303,22 +301,21 @@ let checks t = 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 +let check_raises_lwt msg exn (type a) (f : unit -> a) = + try + let (_ : a) = f () in + Alcotest.failf + "Fail %s: expected function to raise %s, but it returned instead." msg + (Printexc.to_string exn) + with + | e when e = exn -> () + | e -> 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)) + "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 + val sleep : float -> unit end diff --git a/src/irmin-test/dune b/src/irmin-test/dune index 7fbcdc1c45..7b99a329ad 100644 --- a/src/irmin-test/dune +++ b/src/irmin-test/dune @@ -5,13 +5,14 @@ (preprocess (pps ppx_irmin.internal)) (libraries - alcotest-lwt + alcotest astring fmt irmin jsonm logs.fmt - lwt + eio + eio.unix mtime mtime.clock.os) (instrumentation diff --git a/src/irmin-test/irmin_test.mli b/src/irmin-test/irmin_test.mli index 52fa646d48..2bb94c2f78 100644 --- a/src/irmin-test/irmin_test.mli +++ b/src/irmin-test/irmin_test.mli @@ -24,8 +24,8 @@ module Suite : sig val create : name:string -> - ?init:(config:Irmin.config -> unit Lwt.t) -> - ?clean:(config:Irmin.config -> unit Lwt.t) -> + ?init:(config:Irmin.config -> unit) -> + ?clean:(config:Irmin.config -> unit) -> config:Irmin.config -> store:(module S) -> ?stats:(unit -> int * int) -> @@ -35,8 +35,8 @@ module Suite : sig val create_generic_key : name:string -> - ?init:(config:Irmin.config -> unit Lwt.t) -> - ?clean:(config:Irmin.config -> unit Lwt.t) -> + ?init:(config:Irmin.config -> unit) -> + ?clean:(config:Irmin.config -> unit) -> config:Irmin.config -> store:(module Generic_key) -> ?stats:(unit -> int * int) -> @@ -47,8 +47,8 @@ module Suite : sig 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 + val init : t -> config:Irmin.config -> unit + val clean : t -> config:Irmin.config -> unit end val line : string -> unit @@ -65,10 +65,10 @@ module Store : sig string -> ?slow:bool -> ?random_seed:int -> - sleep:(float -> unit Lwt.t) -> - misc:unit Alcotest_lwt.test list -> + sleep:(float -> unit) -> + misc:unit Alcotest.test list -> (Alcotest.speed_level * Suite.t) list -> - unit Lwt.t + unit end module Node = Node diff --git a/src/irmin-test/store.ml b/src/irmin-test/store.ml index ce6b5204dd..a4b114282f 100644 --- a/src/irmin-test/store.ml +++ b/src/irmin-test/store.ml @@ -43,19 +43,16 @@ module Make (S : Generic_key) = struct 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 old k () = Ok (Some k) + let may repo commits = function None -> () | Some f -> f repo commits let may_get_keys repo keys = function - | None -> Lwt.return_unit + | None -> () | Some f -> - let* commits = - Lwt_list.map_p + let commits = + List.map (fun key -> - S.Commit.of_key repo key >|= function + S.Commit.of_key repo key |> function | None -> Alcotest.fail "Cannot read commit hash" | Some c -> c) keys @@ -63,10 +60,10 @@ module Make (S : Generic_key) = struct f repo commits let may_with_branch branches repo hook = - let* heads = - Lwt_list.map_p + let heads = + List.map (fun branch -> - let+ h = S.Head.find branch in + let h = S.Head.find branch in match h with | None -> Alcotest.fail "Cannot read head" | Some head -> head) @@ -81,28 +78,29 @@ module Make (S : Generic_key) = struct 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 + 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 + 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 + 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 + 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 + 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 + let v1' = B.Contents.find t kv1 in check_val "v1" (Some v1) v1'; - let* v2' = B.Contents.find t kv2 in + 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) + B.Repo.close repo; + try + let _ = with_contents repo (fun t -> B.Contents.add t v2) in + Alcotest.fail "Add after close should not be allowed" + with + | Irmin.Closed -> () + | exn -> raise exn in run x test @@ -111,33 +109,31 @@ module Make (S : Generic_key) = struct 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 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 + 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 () -> + check_node "empty node" v; let v1 = B.Node.Val.add v "x" k in - check_node "node: x" v1 >>= fun () -> + check_node "node: x" v1; let v2 = B.Node.Val.add v "x" k in - check_node "node: x (bis)" v2 >>= fun () -> + check_node "node: x (bis)" v2; 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 () -> + check_node "node: x+y" v3; let u = B.Node.Val.add u "z" k in - check_node "node: x+y+z" u >>= fun () -> + check_node "node: x+y+z" u; 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"); @@ -160,69 +156,69 @@ module Make (S : Generic_key) = struct 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 () -> + check_node "node: x+y+z+a" u; let u = B.Node.Val.add u "b" k in - check_node "node: x+y+z+a+b" u >>= fun () -> + check_node "node: x+y+z+a+b" u; let h = B.Node.Hash.hash u in - let* k = with_node repo (fun n -> B.Node.add n 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 + 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 + 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 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 + 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 + 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 + 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 + 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 + 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 + 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 + let k2'' = Graph.find g k3 [ "a" ] in check_val "k2.3" (Some (`Node k2)) k2''; - let* k1'''' = Graph.find g k2' [ "b" ] in + 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 + 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 + 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 + 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 + 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 = + 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' = + 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 + 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 + let all = Graph.list g node in List.iter (fun (s, _) -> if List.mem ~equal:String.equal s !names then @@ -230,32 +226,31 @@ module Make (S : Generic_key) = struct 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) + 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; + 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; + 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; + 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; + S.Repo.close repo; + try + 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" + with + | Irmin.Closed -> () + | exn -> raise exn in run x test @@ -265,46 +260,47 @@ module Make (S : Generic_key) = struct 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 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 + 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 + 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 + 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 + let kr1s = History.closure h ~min:[] ~max:[ kr1 ] in check_keys "g1" [ kr1 ] kr1s; - let* kr2s = History.closure h ~min:[] ~max:[ kr2 ] in + let kr2s = History.closure h ~min:[] ~max:[ kr2 ] in check_keys "g2" [ kr1; kr2 ] kr2s; - let* () = - S.Commit.of_key repo kr1 >|= function + 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) + S.Repo.close repo; + try + let _ = with_info 3 (History.v ~node:kt1 ~parents:[]) in + Alcotest.fail "Add after close should not be allowed" + with + | Irmin.Closed -> () + | exn -> raise exn in run x test @@ -318,9 +314,9 @@ module Make (S : Generic_key) = struct let equal_key = Irmin.Type.(unstage (equal B.Commit.Key.t)) in let h = h repo in let initialise_nodes = - Lwt_list.map_p + List.map (fun i -> - let* kv = + 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) ])) @@ -331,15 +327,15 @@ module Make (S : Generic_key) = struct match nodes with | [] -> assert false | node :: rest -> - let* kr0, _ = with_info 0 (History.v ~node ~parents:[]) in + 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 + let kr1, _ = with_info i (History.v ~node ~parents) in commits.(i) <- kr1; i + 1 in - let+ _ = - Lwt_list.fold_left_s + let _ = + List.fold_left (fun i node -> match i with | 1 -> commit ~node ~parents:[ commits.(0) ] 1 @@ -359,12 +355,12 @@ module Make (S : Generic_key) = struct 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 + 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 + let krs = History.closure h ~min:[] ~max:[ commits.(5) ] in check_keys "all commits under 5" [ commits.(0); @@ -375,7 +371,7 @@ module Make (S : Generic_key) = struct commits.(5); ] krs; - let* krs = + let krs = History.closure h ~min:[ commits.(1); commits.(2) ] ~max:[ commits.(5); commits.(6) ] @@ -390,7 +386,7 @@ module Make (S : Generic_key) = struct commits.(6); ] krs; - let* krs = + let krs = History.closure h ~min:[ commits.(1); commits.(7) ] ~max:[ commits.(4); commits.(8) ] @@ -398,24 +394,24 @@ module Make (S : Generic_key) = struct 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 + 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 + 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 = + 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 = + let () = + let ls = History.closure h ~min:[ commits.(4); commits.(0) ] ~max:[ commits.(4); commits.(6) ] @@ -431,33 +427,34 @@ module Make (S : Generic_key) = struct 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 + 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 () -> + S.Branch.set repo b1 kv1; + may repo [ kv2 ] hook; line "post-update"; - let* k1' = S.Branch.find repo b1 in + 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 + S.Branch.set repo b2 kv2; + 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 + S.Branch.set repo b1 kv2; + let k2'' = S.Branch.find repo b1 in check_val "r1-after-update" (Some kv2) k2''; - let* bs = S.Branch.list repo in + 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 + S.Branch.remove repo b1; + let empty = S.Branch.find repo b1 in check_val "empty" None empty; - let* b2' = S.Branch.list repo in + 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) + S.Repo.close repo; + try + let _ = S.Branch.set repo b1 kv1 in + Alcotest.fail "Add after close should not be allowed" + with + | Irmin.Closed -> () + | exn -> raise exn in run x test @@ -465,28 +462,29 @@ module Make (S : Generic_key) = struct let test repo = let node bindings = with_node repo (fun g -> - let* empty = Graph.empty g in - Lwt_list.fold_left_s + let empty = Graph.empty g in + List.fold_left (fun t (k, v) -> - let* v = with_contents repo (fun t -> B.Contents.add t v) in + 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 + List.fold_left (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 + 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 () -> + check_hash "empty" []; let bindings1 = [ ([ "a" ], "x"); ([ "b" ], "y") ] in - check_hash "1 level" bindings1 >>= fun () -> + check_hash "1 level" bindings1; let bindings2 = [ ([ "a"; "b" ], "x"); ([ "a"; "c" ], "y") ] in - check_hash "2 levels" bindings2 >>= fun () -> S.Repo.close repo + check_hash "2 levels" bindings2; + S.Repo.close repo in run x test @@ -511,27 +509,27 @@ module Make (S : Generic_key) = struct 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 + 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 + check_merge (); + 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' = + 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' = + let kv2' = with_contents repo (fun v -> Irmin.Merge.f (B.Contents.merge v) ~old:(old (Some kv1)) (Some kv1) (Some kv2)) @@ -541,26 +539,26 @@ module Make (S : Generic_key) = struct (* merge nodes *) let g = g repo in (* The empty node *) - let* k0 = with_node repo (fun g -> Graph.v g []) in + 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 + 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 + 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 + 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 = + 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 = 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 + 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 @@ -568,38 +566,38 @@ module Make (S : Generic_key) = struct 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 = + 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; + 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' = + let kr3 = merge_exn "kr3" kr3 in + may_get_keys repo [ kr3 ] hook; + 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 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 = + 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 + 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 + 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 @@ -636,26 +634,23 @@ module Make (S : Generic_key) = struct 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 + 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 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 + assert_lcas_err msg `Max_depth_reached lcas in let assert_last_modified msg ?depth ~n t key expected = - let+ last = S.last_modified ?depth ~n t key in + 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 + 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 @@ -666,51 +661,40 @@ module Make (S : Generic_key) = struct 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 = + 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; + assert_history_empty "nonempty 1 commit" c0 false; + 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 = + assert_history_empty "nonempty 2 commits" c0 false; + 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 = + 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 = + may repo [ c3 ] hook; + 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 + assert_lcas "line lcas 1" ~max_depth:0 3 c3 c4 [ c3 ]; + assert_lcas "line lcas 2" ~max_depth:1 3 c2 c4 [ c2 ]; + assert_lcas "line lcas 3" ~max_depth:2 3 c1 c4 [ c1 ]; + let store = S.of_commit c4 in + assert_last_modified "line last_modified 1" ~n:1 store k0 [ c3 ]; + assert_last_modified "line last_modified 2" ~n:2 store k0 [ c2; c3 ]; + assert_last_modified "line last_modified 3" ~n:3 store k0 [ c0; c2; c3 ]; + assert_last_modified "line last_modified 4" ~depth:1 ~n:3 store k0 [ c3 ]; + assert_last_modified "line last_modified 5" ~n:1 store k2 []; + assert_last_modified "line last_modified 5" ~depth:0 ~n:2 store k0 []; (* test for multiple lca 4(k1) -> 10 (k2) ---> 11(k0, k2) --> 13(k1) --> 15(k1, k2) @@ -719,68 +703,66 @@ module Make (S : Generic_key) = struct | / \ \---> 12 (k0, k1) --> 14 (k2) --> 16 (k2) --> 17 (k0) *) - let* tree = S.Tree.add tree k2 (random_value 1024) in - let* c10 = + 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 = + 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 = + 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 = + 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 = + 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 = + 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 = + 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 = + 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_lcas "x lcas 0" ~max_depth:0 5 c10 c10 [ c10 ]; + assert_lcas "x lcas 1" ~max_depth:0 5 c14 c14 [ c14 ]; + assert_lcas "x lcas 2" ~max_depth:0 5 c10 c11 [ c10 ]; + assert_lcas "x lcas 3" ~max_depth:1 5 c12 c16 [ c12 ]; + assert_lcas "x lcas 4" ~max_depth:1 5 c10 c13 [ c10 ]; + assert_lcas "x lcas 5" ~max_depth:2 5 c13 c14 [ c10 ]; + assert_lcas "x lcas 6" ~max_depth:3 5 c15 c16 [ c12 ]; + assert_lcas "x lcas 7" ~max_depth:3 5 c15 c17 [ c11; c12 ]; + 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* () = + 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* () = + let () = assert_last_modified "x last_modified 4" ~depth:3 ~n:5 store k1 [ c4; c12 ] in - let* () = + let () = assert_last_modified "x last_modified 5" ~depth:2 ~n:3 store k0 [ c11; c17 ] in @@ -792,50 +774,50 @@ module Make (S : Generic_key) = struct | \--|--/ \-----------/ *) - let* c10 = + let c10 = S.Commit.v repo ~info:(info 10) ~parents:[ S.Commit.key c4 ] tree in - let* c11 = + let c11 = S.Commit.v repo ~info:(info 11) ~parents:[ S.Commit.key c10 ] tree in - let* c12 = + let c12 = S.Commit.v repo ~info:(info 12) ~parents:[ S.Commit.key c11 ] tree in - let* c13 = + let c13 = S.Commit.v repo ~info:(info 13) ~parents:[ S.Commit.key c12 ] tree in - let* c14 = + let c14 = S.Commit.v repo ~info:(info 14) ~parents:[ S.Commit.key c11; S.Commit.key c13 ] tree in - let* c15 = + let c15 = S.Commit.v repo ~info:(info 15) ~parents:[ S.Commit.key c13; S.Commit.key c14 ] tree in - let* c16 = + 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 () -> + assert_lcas "weird lcas 1" ~max_depth:0 3 c14 c15 [ c14 ]; + assert_lcas "weird lcas 2" ~max_depth:0 3 c13 c15 [ c13 ]; + assert_lcas "weird lcas 3" ~max_depth:1 3 c12 c15 [ c12 ]; + assert_lcas "weird lcas 4" ~max_depth:1 3 c11 c15 [ c11 ]; + assert_lcas "weird lcas 4" ~max_depth:3 3 c15 c16 [ c11 ]; (* 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 + 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 + 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 + 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 + 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 + let b3 = S.Head.fast_forward t12 c14 in Alcotest.(check ff) "ff 2.2" (Ok ()) b3; - let* c14' = S.Head.get t12 in + let c14' = S.Head.get t12 in check (S.commit_t repo) "ff 2.3" c14 c14'; B.Repo.close repo in @@ -843,13 +825,13 @@ module Make (S : Generic_key) = struct let test_empty ?hook x () = let test repo = - let* t = S.empty repo in - let* h = S.Head.find t in + 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 + let r1 = r1 ~repo in + may repo [ r1 ] hook; + S.set_exn t ~info:S.Info.none [ "b"; "x" ] v1; + let h = S.Head.find t in check T.(option @@ S.commit_t repo) "not empty" (Some r1) h; B.Repo.close repo in @@ -857,13 +839,13 @@ module Make (S : Generic_key) = struct let test_slice ?hook x () = let test repo = - let* t = S.main repo in + 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 + S.set_exn t ~info:(infof "slice") [ "x"; "a" ] a; + S.set_exn t ~info:(infof "slice") [ "x"; "b" ] b; + may_with_branch [ t ] repo hook; + 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 @@ -880,25 +862,25 @@ module Make (S : Generic_key) = struct 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 + let t = S.main repo in + S.set_exn t ~info:(infof "add x/y/z") [ "x"; "y"; "z" ] vx; + let tree = S.get_tree t [ "x" ] in + S.set_tree_exn t ~info:(infof "update") [ "u" ] tree; + 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' = + let tree1 = S.get_tree t [ "u" ] in + S.set_exn t ~info:(infof "add u/x/y") [ "u"; "x"; "y" ] vy; + may_with_branch [ t ] repo hook; + 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" + |> merge_exn "tree" in - S.set_tree_exn t ~info:(infof "merge") [ "u" ] v' >>= fun () -> - let* vy' = S.find t [ "u"; "x"; "y" ] in + S.set_tree_exn t ~info:(infof "merge") [ "u" ] v'; + 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 + let vx' = S.find t [ "u"; "x"; "z" ] in check_val "vx after merge" (Some vx) vx'; B.Repo.close repo in @@ -908,94 +890,94 @@ module Make (S : Generic_key) = struct 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 + let t = S.main repo in + S.set_exn t ~info:(infof "init") [ "a"; "b" ] v1; + 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 + 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 + let b2 = S.mem t [ "a" ] in Alcotest.(check bool) "mem2" false b2; - let* v1' = S.find t [ "a"; "b" ] in + 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 + 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; + let b1 = S.mem t [ "a"; "b" ] in Alcotest.(check bool) "mem3" true b1; - let* b2 = S.mem t [ "a" ] in + let b2 = S.mem t [ "a" ] in Alcotest.(check bool) "mem4" false b2; - let* v1' = S.find t [ "a"; "b" ] in + let v1' = S.find t [ "a"; "b" ] in check_val "v1.1" (Some v1) v1'; - let* b1 = S.mem t [ "a"; "c" ] in + let b1 = S.mem t [ "a"; "c" ] in Alcotest.(check bool) "mem5" true b1; - let* v2' = S.find t [ "a"; "c" ] in + 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 + S.remove_exn t ~info:(infof "remove") [ "a"; "b" ]; + 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 + S.Head.set t r1; + let v1'' = S.find t [ "a"; "b" ] in check_val "v1.3" (Some v1) v1''; - let* ks = S.list t [ "a" ] in + let ks = S.list t [ "a" ] in check_list "path" [ ("b", contents v1) ] ks; - let* () = + 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 + S.remove_exn t ~info:(infof "remove rec") [ "a" ]; + 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 + let () = + try + S.set_exn t ~info:(infof "update root") [] v1; + Alcotest.fail "update root" + with + | Invalid_argument _ -> () + | 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 + S.set_exn t ~info:(infof "update") [ "a" ] v1; + S.remove_exn t ~info:(infof "remove rec --all") []; + 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 + S.set_exn t ~info:(infof "fst one") [ "fst" ] a; + S.set_exn t ~info:(infof "snd one") [ "fst"; "snd" ] b; + let fst = S.find t [ "fst" ] in check_val "data model 1" None fst; - let* snd = S.find t [ "fst"; "snd" ] in + 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 + S.set_exn t ~info:(infof "fst one") [ "fst" ] a; + let fst = S.find t [ "fst" ] in check_val "data model 3" (Some a) fst; - let* snd = S.find t [ "fst"; "snd" ] in + 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 + let tx = S.of_branch repo tagx in + S.Branch.remove repo tagx; + S.Branch.remove repo tagy; + S.set_exn tx ~info:(infof "update") xy vx; + 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) + let t = S.main repo in + S.Repo.close repo; + try + let _ = S.set_exn t ~info:(infof "add after close") [ "a" ] "bar" in + Alcotest.fail "Add after close should not be allowed" + with + | Irmin.Closed -> () + | exn -> raise exn in run x test @@ -1055,16 +1037,16 @@ module Make (S : Generic_key) = struct 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 () -> + let t1 = S.main repo in + S.set_exn t1 ~info [ "a"; "b" ] "foo"; (* Testing cache *) S.Tree.reset_counters (); - let* v = S.get_tree t1 [] in + 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 + 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 + 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; @@ -1072,7 +1054,7 @@ module Make (S : Generic_key) = struct 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 () -> + S.set_tree_exn t1 ~info [] v; 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; @@ -1089,22 +1071,22 @@ module Make (S : Generic_key) = struct let test_trees x () = let test repo = - let* t = S.main repo in + 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 = + let v1 = S.Tree.singleton [ "foo"; "bar"; "toto" ] foo2 |> with_binding [ "foo"; "toto" ] foo1 in S.Tree.clear v1; - let* () = + 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* () = + let () = S.Tree.fold ~depth:(`Eq 1) ~force:`True (S.Tree.empty ()) () ~contents:(fun k _ -> assert (List.length k = 1); @@ -1114,10 +1096,10 @@ module Make (S : Generic_key) = struct Alcotest.fail "node") in let fold depth ecs ens = - let* cs, ns = + 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)) + ~contents:(fun path _ (cs, ns) -> (path :: cs, ns)) + ~node:(fun path _ (cs, ns) -> (cs, path :: ns)) ([], []) in let paths = Alcotest.slist (testable S.Path.t) compare in @@ -1126,56 +1108,53 @@ module Make (S : Generic_key) = struct ecs cs; Alcotest.(check paths) (Fmt.str "nodes depth=%a" Fmt.(Dump.option pp_depth) depth) - ens ns; - Lwt.return () + ens ns in - let* () = + 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 (`Eq 0)) [] [ [] ]; + fold (Some (`Eq 1)) [] [ [ "foo" ] ]; + let () = fold (Some (`Eq 2)) [ [ "foo"; "toto" ] ] [ [ "foo"; "bar" ] ] in + fold (Some (`Lt 2)) [] [ []; [ "foo" ] ]; + let () = fold (Some (`Le 2)) [ [ "foo"; "toto" ] ] [ []; [ "foo" ]; [ "foo"; "bar" ] ] in - let* () = + 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 + fold (Some (`Gt 2)) [ [ "foo"; "bar"; "toto" ] ] []; + 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 + 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 + 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 + 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.set_tree_exn t ~info:(infof "empty tree") [] v1; + let head = S.Head.get t in S.Commit.key head |> fun head -> - let* commit = B.Commit.find (ct repo) head in + 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 + let node = B.Node.find (n repo) node in check T.(option B.Node.Val.t) "empty tree" @@ -1193,42 +1172,42 @@ module Make (S : Generic_key) = struct 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 () = check_length "bindings1 length" v2 in + let () = let t = contents "foo" in check_length "contents length" t in @@ -1246,8 +1225,8 @@ module Make (S : Generic_key) = struct ("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 _ = 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"); @@ -1257,198 +1236,192 @@ module Make (S : Generic_key) = struct ("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 + 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 + 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 + 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 + 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 = + let c0 = S.Tree.singleton [ "foo"; "a" ] "1" |> with_binding [ "foo"; "b"; "c" ] "2" - >>= with_binding [ "foo"; "c" ] "3" - >>= with_binding [ "foo"; "d" ] "4" + |> 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 + 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 + 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 + 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 + 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 + let c0 = + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + let foo2' = S.Tree.find_all v [ "foo"; "2" ] in + check_val "foo2" (normal foo2) foo2' + in + let v0 = List.fold_left (fun v0 (k, v) -> S.Tree.add v0 k v) v0 nodes in + check_tree v0; + S.set_tree_exn t ~info:(infof "update_path b/") [ "b" ] v0; + S.set_tree_exn t ~info:(infof "update_path a/") [ "a" ] v0; + 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 + 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 + 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' = + let v0 = S.get_tree t [ "b" ] in + check_tree v0; + S.set_exn t ~info:(infof "update b/x") [ "b"; "x" ] foo1; + 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" + |> 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 + S.set_tree_exn t ~info:(infof "merge_path") [ "b" ] v'; + 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 + let () = + List.iteri (fun i (k, v) -> - let* v' = S.find_all t ("a" :: k) in + 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) + let v' = S.find_all t ("b" :: k) in + check_val ("b" ^ string_of_int i) (normal v) v') 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 + 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; + 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 + 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; + 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 r1 = r1 ~repo in + let r2 = r2 ~repo in let i0 = S.Info.empty in - let* c = + 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.Head.set t c; + 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 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 + 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.set_exn tt ~info:(infof "update") px vx; + let tree = S.get_tree tt [] in S.Tree.clear tree; - let* s = S.Tree.stats tree in + 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 + 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 + 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 + 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 @@ -1464,59 +1437,58 @@ module Make (S : Generic_key) = struct 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 + let c0 = + 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 -> + List.fold_left (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 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) + let bindings = + try S.Tree.list t [] with + | S.Tree.Pruned_hash _ -> [] + | e -> raise e in - Lwt_list.iter_s (fun (s, v) -> aux (p @ [ s ]) v) bindings + List.iter (fun (s, v) -> aux (p @ [ s ]) v) bindings in S.Tree.produce_proof repo key (fun t -> - let+ () = aux [] t in + let () = aux [] t in (t, ())) in - let* p0, () = to_proof c0 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 + 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 + 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 + 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 + 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 + 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 = @@ -1539,63 +1511,59 @@ module Make (S : Generic_key) = struct in let check_proof_f0 p = let t = S.Tree.Proof.to_tree p in - let* i = S.Tree.find t [ "bar"; "age" ] 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 + 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 + 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) + let () = + try + let _ = S.Tree.find t [ "foo"; "version" ] in + Alcotest.fail "inside: should have raise: pruned_hash exn" + with + | S.Tree.Pruned_hash _ | B.Node.Val.Dangling_hash _ -> () + | e -> raise 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 + 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 + let tree = + List.fold_left (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 + 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 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 + 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 + 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 + let t = S.Tree.remove t4 [ "bar" ] in (* Trigger certain paths in [S.Tree] during "verify" *) let portable = @@ -1606,46 +1574,45 @@ module Make (S : Generic_key) = struct 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_to_map portable in + let () = trigger_node_to_map portable_dirty in let trigger_node_length t = - let+ (_ : int) = S.Tree.length t [] in + let (_ : int) = S.Tree.length t [] in () in - let* () = trigger_node_length portable in - let* () = trigger_node_length portable_dirty 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 () = 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 + let _ = S.to_backend_portable_node n in () in - let* () = trigger_node_to_backend_portable portable_dirty in - - Lwt.return (t, ()) + let () = trigger_node_to_backend_portable portable_dirty in + (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 + 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 p, () = S.Tree.produce_proof repo key f1 in - let* () = check_proof_f1 p in + let () = check_proof_f1 p in let check_proof f = - let* p, () = S.Tree.produce_proof repo key f in + 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 + let r = S.Tree.verify_proof p f in match r with | Ok (_, ()) -> () | Error e -> @@ -1653,7 +1620,7 @@ module Make (S : Generic_key) = struct (Irmin.Type.pp S.Tree.verifier_error_t) e in - let* () = Lwt_list.iter_s check_proof [ f0; f1 ] in + let () = List.iter check_proof [ f0; f1 ] in (* check env sharing *) let tree () = @@ -1673,7 +1640,7 @@ module Make (S : Generic_key) = struct check S.Tree.Private.Env.t msg env env' in let x = ref None in - let* _ = + let _ = S.Tree.produce_proof repo key (fun t -> check_env_empty "env should be set inside the proof" t false; x := Some t; @@ -1683,59 +1650,59 @@ module Make (S : Generic_key) = struct (* test changing subtress: check that envirnoment is attached only the tree roots *) - let* t1 = S.Tree.add_tree t [ "foo" ] t0 in + 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 + 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 + 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 + 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 + 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 + 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, ())) + (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 + 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 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 () = 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; @@ -1745,10 +1712,8 @@ module Make (S : Generic_key) = struct Contents ("yo", S.Metadata.default); ] in - let* () = - Lwt_list.iter_s - (fun c -> check_bad_proof (proof ~state:c ())) - some_contents + let () = + List.iter (fun c -> check_bad_proof (proof ~state:c ())) some_contents in B.Repo.close repo in @@ -1759,50 +1724,50 @@ module Make (S : Generic_key) = struct let size = 500_000 in let c0 = S.Tree.empty () in let rec wide_node i c = - if i >= size then Lwt.return c + if i >= size then c else - S.Tree.add c [ "foo"; string_of_int i ] (string_of_int i) >>= fun c -> + 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 -> + 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)) + 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) + i) 0 - >>= fun nb_contents -> + |> 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' -> + 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* _ = + 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 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 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 () = let h' = B.Node.Hash.hash v1 in - let+ h = with_node repo (fun n -> B.Node.add n 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 @@ -1814,10 +1779,10 @@ module Make (S : Generic_key) = struct let v0 = B.Node.Val.remove v1 "x" in check B.Node.Val.t "remove x" v v0 in - let* () = + 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 -> + 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 @@ -1828,9 +1793,9 @@ module Make (S : Generic_key) = struct 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 + | None -> () + | Some _ -> Alcotest.fail "value 500000 should not be found")); + B.Repo.close repo in run x test @@ -1839,16 +1804,15 @@ module Make (S : Generic_key) = struct let size = 500_000 in let c0 = S.Tree.empty () in let rec wide_node i c = - if i >= size then Lwt.return c + if i >= size then c else - S.Tree.add c [ "foo"; string_of_int i ] (string_of_int i) >>= fun c -> + 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 -> + wide_node 0 c0 |> fun c -> + S.main repo |> fun t -> + S.set_tree_exn t [ "wide" ] ~info:(infof "commit_wide_nodes") c; + S.list t [ "wide"; "foo" ] |> fun ls -> Alcotest.(check int) "commit wide node list" size (List.length ls); B.Repo.close repo in @@ -1858,46 +1822,46 @@ module Make (S : Generic_key) = struct 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 + let t1 = S.main repo in + S.set_exn t1 ~info:(infof "update a/b") [ "a"; "b" ] v1; + 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; + let r2 = S.Head.get t1 in + S.set_exn t1 ~info:(infof "update a/d") [ "a"; "d" ] v1; + 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 = 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 = 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 + let t2 = S.of_branch repo tag in + S.Head.set t2 partial; + let b1 = S.mem t2 [ "a"; "b" ] in Alcotest.(check bool) "mem-ab" true b1; - let* b2 = S.mem t2 [ "a"; "c" ] in + let b2 = S.mem t2 [ "a"; "c" ] in Alcotest.(check bool) "mem-ac" true b2; - let* b3 = S.mem t2 [ "a"; "d" ] in + let b3 = S.mem t2 [ "a"; "d" ] in Alcotest.(check bool) "mem-ad" true b3; - let* v1' = S.get t2 [ "a"; "d" ] in + 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 + S.Head.set t2 r2; + 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 + S.Head.set t2 full; + S.Head.set t2 r2; + let b4 = S.mem t2 [ "a"; "d" ] in Alcotest.(check bool) "mem-ad" false b4; B.Repo.close repo in @@ -1911,49 +1875,42 @@ module Make (S : Generic_key) = struct 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 () -> + Dot.output_buffer t ~date buf; 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 + close_out oc 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 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* () = + 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* () = + let () = S.set_exn t1 ~info:(infof "update main:a/b/b") [ "a"; "b"; "b" ] v3 in - let* () = + 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 + output_file x t1 "before"; + let m = S.merge_into ~info:(infof "merge test into main") t2 ~into:t1 in + merge_exn "m" m; + may_with_branch [ t1 ] repo hook; + output_file x t1 "after"; + 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'; @@ -1967,21 +1924,21 @@ module Make (S : Generic_key) = struct 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 + f |> function None -> Alcotest.fail msg | Some c -> 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 old () = Ok None in + let t = S.main repo in + S.set_exn t ~info:(infof "add x/y/z") [ "x"; "y"; "z" ] vx; + 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; + 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; + 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 @@ -1989,14 +1946,14 @@ module Make (S : Generic_key) = struct ~old (Some (S.Commit.key c3)) (Some (S.Commit.key c2))) - >>= merge_exn "commit" - >>= function - | None -> Lwt.return_unit + |> merge_exn "commit" + |> function + | None -> () | 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 + let k = none_fail (S.Commit.of_key repo c4) "of hash" in + S.Branch.set repo "foo" k; + 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 @@ -2005,67 +1962,67 @@ module Make (S : Generic_key) = struct 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* _ = + 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; + S.set_exn bar ~info:(infof "update bar:b") [ "b" ] v1; + may_with_branch [ foo; bar ] repo hook; + let _ = S.merge_into ~info:(infof "merge bar into foo") bar ~into:foo - >>= merge_exn "merge unrelated" + |> 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) + | i -> (fun () -> fn i |> Eio.Fiber.yield) :: write fn (i - 1) - let perform l = Lwt_list.iter_p (fun f -> f ()) l + let perform l = List.iter (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) + | i -> (fun () -> fn i |> fun v -> check i v) :: read fn check (i - 1) let test_concurrent_low x () = - let test_branches repo = + let test_branches repo () = let k = b1 in - let* v = r1 ~repo 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 -> 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 1); perform (write 10 @ read 10 @ write 10 @ read 10) in - let test_contents repo = - let* k = kv2 ~repo 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) + let _ = with_contents repo (fun t -> B.Contents.add t v) in + ()) in let read = read - (fun _i -> B.Contents.find t k >|= get) + (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 1); perform (write 10 @ read 10 @ write 10 @ read 10) in run x (fun repo -> - Lwt.choose [ test_branches repo; test_contents repo ] >>= fun () -> + Eio.Fiber.all [ test_branches repo; test_contents repo ]; 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 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 @@ -2074,13 +2031,14 @@ module Make (S : Generic_key) = struct (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) + perform (write t1 10 @ write t2 10); + 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 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)) @@ -2090,35 +2048,38 @@ module Make (S : Generic_key) = struct (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) + perform (write t1 10 @ write t2 10); + perform (read t1 10) in run x (fun repo -> - test_one repo >>= fun () -> - test_multi repo >>= fun () -> B.Repo.close repo) + test_one repo; + test_multi repo; + 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 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 () -> + let m = S.clone ~src:t ~dst:tag in + S.set_exn m ~info:(infof "update") (k i) (v i); + Eio.Fiber.yield (); S.merge_into ~info:(infof "update: multi %d" i) m ~into:t - >>= merge_exn "update: multi") + |> 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 + S.set_exn t1 ~info:(infof "update") (k 0) (v 0); + perform (write t1 1 10 @ write t2 2 10); + perform (read t1 10); + B.Repo.close repo in run x test @@ -2127,12 +2088,12 @@ module Make (S : Generic_key) = struct let test_with_tree x () = let test repo = - let* t = S.main repo in - let update ?retries key strategy r w = + 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 + let v = Eio.Stream.take r in Some (S.Tree.of_contents v)) - >>= Lwt_mvar.put w + |> Eio.Stream.add w in let check_ok = function | Ok () -> () @@ -2152,87 +2113,91 @@ module Make (S : Generic_key) = struct 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 + let rx = Eio.Stream.create 1 in + let wx = Eio.Stream.create 1 in + let ry = Eio.Stream.create 1 in + let wy = Eio.Stream.create 1 in + S.set_exn t ~info:(infof "init") [ "a" ] "0"; + Eio.Fiber.all [ 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 + (fun () -> + Eio.Stream.add rx "1"; + Eio.Stream.take wx |> check_ok; + 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 ); + Eio.Stream.add ry "2"; + Eio.Stream.take wy |> check_ok; + 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 + let rx = Eio.Stream.create 1 in + let wx = Eio.Stream.create 1 in + let ry = Eio.Stream.create 1 in + let wy = Eio.Stream.create 1 in + let rz = Eio.Stream.create 1 in + let wz = Eio.Stream.create 1 in + S.set_exn t ~info:(infof "init") [ "a" ] "0"; + Eio.Fiber.all [ 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 + (fun () -> + Eio.Stream.add rx "1"; + Eio.Stream.take wx |> check_ok; + 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 + Eio.Stream.add ry "2"; + let e = Eio.Stream.take wy in check_test (Some (S.Tree.of_contents "1")) e; - let* a = S.get t [ "a" ] in + let a = S.get t [ "a" ] in Alcotest.(check string) "test-and-set y" "1" a; - Lwt_mvar.put rz "3" >>= fun () -> + Eio.Stream.add rz "3"; (* 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 ); + Eio.Stream.add rz "4"; + Eio.Stream.take wz |> check_ok; + 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 + let rx = Eio.Stream.create 1 in + let wx = Eio.Stream.create 1 in + let ry = Eio.Stream.create 1 in + let wy = Eio.Stream.create 1 in + let rz = Eio.Stream.create 1 in + let wz = Eio.Stream.create 1 in + S.set_exn t ~info:(infof "init") [ "a" ] "0"; + Eio.Fiber.all [ 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 + (fun () -> + Eio.Stream.add rx "1"; + Eio.Stream.take wx |> check_ok; + 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 + Eio.Stream.add ry "2"; + Eio.Stream.take wy |> check_conflict; + let a = S.get t [ "a" ] in Alcotest.(check string) "merge y" a "1"; - Lwt_mvar.put rz "3" >>= fun () -> + Eio.Stream.add rz "3"; (* 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" ); + Eio.Stream.add rz "4"; + Eio.Stream.take wz |> check_ok; + 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 + set () |> test_and_set |> merge; + B.Repo.close repo in run x test @@ -2240,14 +2205,12 @@ module Make (S : Generic_key) = struct 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 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 + fn () |> function + | true -> [%log.debug "%d: ok!" d] | false -> [%log.debug "%d: conflict, retrying (%d)." d i]; aux (i + 1) @@ -2257,21 +2220,23 @@ module Make (S : Generic_key) = struct let write t n = write (fun i -> retry i (fun () -> - let* test = S.Head.find t in + 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)) + let m = S.clone ~src:t ~dst:tag in + S.set_exn m ~info:(infof "update") (k i) (v i); + let set = S.Head.find m in + Eio.Fiber.yield (); + 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 + S.set_exn t1 ~info:(infof "update") (k 0) (v 0); + perform (write t1 1 5 @ write t2 2 5); + perform (read t1 5); + B.Repo.close repo in run x test @@ -2284,27 +2249,27 @@ module Make (S : Generic_key) = struct 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 = + let contents (s : string) : S.contents_key = with_contents repo (fun c -> B.Contents.add c s) in - let node (s : string) : S.node_key Lwt.t = + let node (s : string) : S.node_key = with_node repo (fun n -> - let* contents = contents s in + 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 = + let commit (s : string) : S.commit_key = with_commit repo (fun c -> - let* node = node s in + 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 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 + let node_3 = + let contents_foo = contents "foo" in S.Backend.Node.Val.of_list [ ("foo", `Contents (contents_foo, S.Metadata.default)); @@ -2312,24 +2277,24 @@ module Make (S : Generic_key) = struct ] in let tree_3 = S.Tree.of_node (S.of_backend_node repo node_3) in - let* _ = + 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 + let t = S.main repo in + S.set_tree_exn t [ "1" ] tree_1 ~info; + S.set_tree_exn t [ "2" ] tree_2 ~info; + 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_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 + S.set_tree_exn t [ "3" ] ~parents:[ commit ] tree_3 ~info; + let t1 = S.find_tree t [ "1" ] in Alcotest.(check (option tree_t)) "shallow tree" (Some tree_1) t1; B.Repo.close repo in @@ -2344,18 +2309,18 @@ module Make (S : Generic_key) = struct Buffer.contents buf in let rec add_entries acc = function - | 0 -> Lwt.return acc + | 0 -> acc | i -> let s = string_of_int i in - let* acc = S.Tree.add acc [ s ] s 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 tree = create_tree () in + let c = S.Commit.v repo ~info:S.Info.empty ~parents:[] tree in - let* node_b = + let node_b = S.Tree.destruct tree |> (function `Contents _ -> assert false | `Node n -> n) |> S.to_backend_node @@ -2367,7 +2332,7 @@ module Make (S : Generic_key) = struct 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 = + 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 @@ -2379,7 +2344,7 @@ module Make (S : Generic_key) = struct (Irmin.Type.pp S.Backend.Node.Val.t) node_b; - let* blob_k = + 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 @@ -2394,9 +2359,9 @@ module Make (S : Generic_key) = struct 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 + run x (test @@ fun () -> S.Tree.empty ()); (* with a length one node, *) - run x (test @@ fun () -> add_entries (S.Tree.empty ()) 1) >>= fun () -> + run x (test @@ fun () -> add_entries (S.Tree.empty ()) 1); (* 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) @@ -2488,7 +2453,6 @@ let run name ?(slow = false) ?random_seed ~sleep ~misc tl = 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 name (misc @ tl1) + Alcotest.run name (misc @ tl1) diff --git a/src/irmin-test/store.mli b/src/irmin-test/store.mli index 57aeeb89dc..5c9635550f 100644 --- a/src/irmin-test/store.mli +++ b/src/irmin-test/store.mli @@ -18,7 +18,7 @@ val run : string -> ?slow:bool -> ?random_seed:int -> - sleep:(float -> unit Lwt.t) -> - misc:unit Alcotest_lwt.test list -> + sleep:(float -> unit) -> + misc:unit Alcotest.test list -> (Alcotest.speed_level * Common.t) list -> - unit Lwt.t + unit diff --git a/src/irmin-test/store_graph.ml b/src/irmin-test/store_graph.ml index 2d576ea5d6..f30fa37dd8 100644 --- a/src/irmin-test/store_graph.ml +++ b/src/irmin-test/store_graph.ml @@ -38,8 +38,7 @@ module Make (S : Generic_key) = struct 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 + visited := `Node k :: !visited in let contents ?order k = let e = `Contents (k, S.Metadata.default) in @@ -48,13 +47,12 @@ module Make (S : Generic_key) = struct (Irmin.Type.pp B.Contents.Key.t) k; (match order with None -> () | Some f -> f e); - visited := e :: !visited; - Lwt.return_unit + visited := e :: !visited in let test_rev_order ~nodes ~max = let oldest = List.hd nodes in let contents = contents ~order:(rev_order oldest) in - let+ () = + let () = Graph.iter (g repo) ~min:[] ~max ~node ~contents ~rev:true () in List.iter @@ -68,7 +66,7 @@ module Make (S : Generic_key) = struct let test_in_order ~nodes ~max = let oldest = List.hd nodes in let contents = contents ~order:(in_order oldest) in - let+ () = + let () = Graph.iter (g repo) ~min:[] ~max ~node ~contents ~rev:false () in List.iter @@ -81,10 +79,10 @@ module Make (S : Generic_key) = struct let skip_node k = if mem (`Node k) to_skip then ( skipped := `Node k :: !skipped; - Lwt.return_true) - else Lwt.return_false + true) + else false in - let+ () = + let () = Graph.iter (g repo) ~min:[] ~max ~node ~contents ~skip_node ~rev:false () in @@ -100,8 +98,7 @@ module Make (S : Generic_key) = struct not_visited in let test_min_max ~nodes ~min ~max ~not_visited = - Graph.iter (g repo) ~min ~max ~node ~contents ~rev:false () - >|= fun () -> + Graph.iter (g repo) ~min ~max ~node ~contents ~rev:false () |> fun () -> List.iter (fun k -> if mem k not_visited && mem k !visited then @@ -111,22 +108,21 @@ module Make (S : Generic_key) = struct nodes in let test1 () = - let* foo = with_contents repo (fun c -> B.Contents.add c "foo") in + 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 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 () -> + test_rev_order ~nodes ~max:[ k2; k3 ]; visited := []; - test_in_order ~nodes ~max:[ k2; k3 ] >>= fun () -> + test_in_order ~nodes ~max:[ k2; k3 ]; visited := []; skipped := []; - test_skip ~max:[ k2; k3 ] ~to_skip:[ `Node k1 ] ~not_visited:[] - >>= fun () -> + test_skip ~max:[ k2; k3 ] ~to_skip:[ `Node k1 ] ~not_visited:[]; visited := []; - let* () = + let () = test_min_max ~nodes ~min:[ k1 ] ~max:[ k2 ] ~not_visited:[ `Contents foo_k; `Node k3 ] in @@ -137,12 +133,11 @@ module Make (S : Generic_key) = struct 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 = 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 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 () -> + test_rev_order ~nodes:[ `Contents foo_k; `Node k1 ] ~max:[ k1 ]; visited := []; skipped := []; test_skip ~max:[ k1 ] @@ -150,13 +145,13 @@ module Make (S : Generic_key) = struct ~not_visited:[ `Contents foo_k ] in let test3 () = - let* foo = with_contents repo (fun c -> B.Contents.add c "foo") in + 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 = + 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) ]) @@ -172,25 +167,25 @@ module Make (S : Generic_key) = struct ] in visited := []; - test_rev_order ~nodes ~max:[ kc ] >>= fun () -> + test_rev_order ~nodes ~max:[ kc ]; visited := []; - test_in_order ~nodes ~max:[ kc ] >>= fun () -> + test_in_order ~nodes ~max:[ kc ]; visited := []; skipped := []; - let* () = + let () = test_skip ~max:[ kc ] ~to_skip:[ `Node ka1; `Node ka2 ] ~not_visited:[ `Node kb1 ] in visited := []; skipped := []; - let* () = + let () = test_skip ~max:[ kc ] ~to_skip:[ `Node ka1; `Node ka2; `Node kb2 ] ~not_visited:[ `Node kb1; `Contents foo_k ] in visited := []; - let* () = + let () = test_min_max ~nodes ~min:[ kb1 ] ~max:[ ka1 ] ~not_visited:[ `Contents foo_k; `Node ka2; `Node kb2; `Node kc ] in @@ -199,9 +194,10 @@ module Make (S : Generic_key) = struct ~not_visited: [ `Contents foo_k; `Node kb1; `Node ka1; `Node ka2; `Node kb2 ] in - test1 () >>= fun () -> - test2 () >>= fun () -> - test3 () >>= fun () -> B.Repo.close repo + test1 (); + test2 (); + test3 (); + B.Repo.close repo in run x test diff --git a/src/irmin-test/store_watch.ml b/src/irmin-test/store_watch.ml index 5b19ebed0d..06e55140c2 100644 --- a/src/irmin-test/store_watch.ml +++ b/src/irmin-test/store_watch.ml @@ -18,7 +18,7 @@ open! Import open Common module type Sleep = sig - val sleep : float -> unit Lwt.t + val sleep : float -> unit end module Make (Log : Logs.LOG) (Zzz : Sleep) (S : Generic_key) = struct @@ -26,7 +26,8 @@ module Make (Log : Logs.LOG) (Zzz : Sleep) (S : Generic_key) = struct let sleep ?(sleep_t = 0.01) () = let sleep_t = min sleep_t 1. in - Lwt.pause () >>= fun () -> Zzz.sleep sleep_t + Eio.Fiber.yield (); + Zzz.sleep sleep_t let now_s () = Mtime.span_to_s (Mtime_clock.elapsed ()) @@ -38,13 +39,11 @@ module Make (Log : Logs.LOG) (Zzz : Sleep) (S : Generic_key) = struct 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 + try fn (str i) 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 () -> + sleep ~sleep_t () |> fun () -> [%log.debug "Test.retry %s" (str i)]; aux (i + 1) in @@ -52,8 +51,8 @@ module Make (Log : Logs.LOG) (Zzz : Sleep) (S : Generic_key) = struct let test_watch_exn x () = let test repo = - let* t = S.main repo in - let* h = S.Head.find t in + 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 @@ -61,67 +60,67 @@ module Make (Log : Logs.LOG) (Zzz : Sleep) (S : Generic_key) = struct 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 + 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") + let u = + S.watch ?init:h t (fun v -> + check v; + failwith "test") in - let* v = - S.watch ?init:h t (fun v -> check v >>= fun () -> Lwt.fail_with "test") + let v = + S.watch ?init:h t (fun v -> + check v; + failwith "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* () = + let w = S.watch ?init:h t (fun v -> check v) in + S.set_exn t ~info:(infof "update") key v1; + let () = retry ~while_:(fun () -> !r < 3) (fun n -> Alcotest.(check int) ("watch 1 " ^ n) 3 !r) in - let* h = S.Head.find t in + let h = S.Head.find t in old_head := h; - S.set_exn t ~info:(infof "update") key v2 >>= fun () -> - let* () = + S.set_exn t ~info:(infof "update") key v2; + 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 + S.unwatch u; + S.unwatch v; + S.unwatch w; + let h = S.Head.get t in old_head := Some h; - let* u = + let u = S.watch_key ~init:h t key (fun _ -> incr r; failwith "test") in - let* v = + 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) + failwith "test") in - S.set_exn t ~info:(infof "update") key v1 >>= fun () -> - let* () = + let w = S.watch_key ~init:h t key (fun _ -> incr r) in + S.set_exn t ~info:(infof "update") key v1; + 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* () = + S.set_exn t ~info:(infof "update") key v2; + 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 () -> + S.unwatch u; + S.unwatch v; + S.unwatch w; Alcotest.(check unit) "ok!" () (); B.Repo.close repo in @@ -135,7 +134,7 @@ module Make (Log : Logs.LOG) (Zzz : Sleep) (S : Generic_key) = struct in let check_workers msg p w = match x.stats with - | None -> Lwt.return_unit + | None -> () | Some stats -> retry ~while_:(fun _ -> true) @@ -187,7 +186,7 @@ module Make (Log : Logs.LOG) (Zzz : Sleep) (S : Generic_key) = struct 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 () -> + check_workers msg p w; retry ?sleep_t ~while_:(fun () -> less_than b a (* While [b] converges toward [a] *)) (fun s -> @@ -196,8 +195,8 @@ module Make (Log : Logs.LOG) (Zzz : Sleep) (S : Generic_key) = struct 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 + let () = + match sleep_t with None -> () | Some s -> Zzz.sleep s in let () = match head with @@ -205,7 +204,7 @@ module Make (Log : Logs.LOG) (Zzz : Sleep) (S : Generic_key) = struct | `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 = @@ -229,7 +228,7 @@ module Make (Log : Logs.LOG) (Zzz : Sleep) (S : Generic_key) = struct | `Remove -> xremove in let rec aux pre = function - | 0 -> Lwt.return_unit + | 0 -> () | i -> let pre_w = if on then (1, if i = n && first then 0 else 1) else (0, 0) @@ -237,18 +236,19 @@ module Make (Log : Logs.LOG) (Zzz : Sleep) (S : Generic_key) = struct 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 () -> + check `Pre (n - i) pre_w pre; [%log.debug "[waiting for] %s" (msg `Post (n - i) post_w post)]; - fn (n - i) >>= fun () -> + fn (n - i); (* check post-condition *) - check `Post (n - i) post_w post >>= fun () -> aux post (i - 1) + check `Post (n - i) post_w post; + 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 + 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 @@ -256,36 +256,36 @@ module Make (Log : Logs.LOG) (Zzz : Sleep) (S : Generic_key) = struct let stops_0 = ref [] in let stops_1 = ref [] in let rec watch = function - | 0 -> Lwt.return_unit + | 0 -> () | n -> let t = if n mod 2 = 0 then t1 else t2 in - let* s = S.watch t process 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 () -> + S.set_exn t1 ~info:(infof "update") [ "a"; "b" ] v1; + S.Branch.remove repo1 S.Branch.main; + State.check "init" (0, 0) (0, 0, 0) state; + watch 100; + State.check "watches on" (1, 0) (0, 0, 0) state; + S.set_exn t1 ~info:(infof "update") [ "a"; "b" ] v1; + State.check "watches adds" (1, 1) (100, 0, 0) state; + S.set_exn t2 ~info:(infof "update") [ "a"; "c" ] v1; + State.check "watches updates" (1, 1) (100, 100, 0) state; + S.Branch.remove repo S.Branch.main; + State.check "watches removes" (1, 1) (100, 100, 100) state; + List.iter (fun f -> S.unwatch f) !stops_0; + S.set_exn t2 ~info:(infof "update") [ "a" ] v1; + State.check "watches half off" (1, 1) (150, 100, 100) state; + List.iter (fun f -> S.unwatch f) !stops_1; + S.set_exn t1 ~info:(infof "update") [ "a" ] v2; + State.check "watches off" (0, 0) (150, 100, 100) state; [%log.debug "WATCH-ALL"]; let state = State.empty () in - let* head = r1 ~repo 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 @@ -296,18 +296,18 @@ module Make (Log : Logs.LOG) (Zzz : Sleep) (S : Generic_key) = struct let tag = Fmt.str "t%d" n in S.Branch.remove repo tag) in - let* main = S.Branch.get repo "main" in - let* u = + 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 () -> + add true (0, 0, 0) 10 ~first:true; + remove true (10, 0, 0) 5; + S.unwatch u; + add false (10, 0, 5) 4; + remove false (10, 0, 5) 4; [%log.debug "WATCH-KEY"]; let state = State.empty () in let path1 = [ "a"; "b"; "c" ] in @@ -316,36 +316,33 @@ module Make (Log : Logs.LOG) (Zzz : Sleep) (S : Generic_key) = struct 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) + S.set_exn t1 ~info:(infof "set1") path1 v; + S.set_exn t1 ~info:(infof "set2") path2 v; + S.set_exn t1 ~info:(infof "set3") path3 v) 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) + S.set_exn t2 ~info:(infof "update1") path1 v; + S.set_exn t2 ~info:(infof "update2") path2 v; + S.set_exn t2 ~info:(infof "update3") path3 v) 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) + S.remove_exn t1 ~info:(infof "remove1") path1; + S.remove_exn t1 ~info:(infof "remove2") path2; + S.remove_exn t1 ~info:(infof "remove3") path3) 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 () -> + S.remove_exn t1 ~info:(infof "clean") []; + 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; + update true (1, 0, 0) 10; + remove true (1, 10, 0) 1; + S.unwatch u; + add false (1, 10, 1) 3; + update false (1, 10, 1) 5; + remove false (1, 10, 1) 4; [%log.debug "WATCH-MORE"]; let state = State.empty () in let update = @@ -354,19 +351,19 @@ module Make (Log : Logs.LOG) (Zzz : Sleep) (S : Generic_key) = struct 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) + S.set_exn t2 ~info:(infof "update1") path1 v; + S.set_exn t2 ~info:(infof "update2") path2 v; + S.set_exn t2 ~info:(infof "update3") path3 v) 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 + S.remove_exn t1 ~info:(infof "remove") [ "a" ]; + S.set_exn t1 ~info:(infof "prepare") [ "a"; "b"; "c" ] ""; + 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; + S.unwatch u; + update false (0, 10, 0) 10; + B.Repo.close repo; + B.Repo.close repo1 in run x test diff --git a/src/irmin/append_only_intf.ml b/src/irmin/append_only_intf.ml index b5d318d4aa..833ab2d7b2 100644 --- a/src/irmin/append_only_intf.ml +++ b/src/irmin/append_only_intf.ml @@ -26,7 +26,7 @@ module type S = sig include Read_only.S (** @inline *) - val add : [> write ] t -> key -> value -> unit Lwt.t + val add : [> write ] t -> key -> value -> unit (** Write the contents of a value to the store. *) include Closeable with type 'a t := 'a t diff --git a/src/irmin/atomic_write.ml b/src/irmin/atomic_write.ml index 7bf9b0db10..8cfe8d7dfa 100644 --- a/src/irmin/atomic_write.ml +++ b/src/irmin/atomic_write.ml @@ -14,7 +14,6 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Import include Atomic_write_intf module Check_closed_store (AW : S) = struct @@ -42,7 +41,7 @@ module Check_closed_store (AW : S) = struct let unwatch t w = (get_if_open_exn t |> AW.unwatch) w let close t = - if !(t.closed) then Lwt.return_unit + if !(t.closed) then () else ( t.closed := true; AW.close t.t) @@ -56,6 +55,6 @@ struct include Check_closed_store (AW) let v conf = - let+ t = AW.v conf in + let t = AW.v conf in { closed = ref false; t } end diff --git a/src/irmin/atomic_write_intf.ml b/src/irmin/atomic_write_intf.ml index 15f506c225..deb4e07a53 100644 --- a/src/irmin/atomic_write_intf.ml +++ b/src/irmin/atomic_write_intf.ml @@ -30,13 +30,12 @@ module type S = sig include Read_only.S with type _ t := t (** @inline *) - val set : t -> key -> value -> unit Lwt.t + val set : t -> key -> value -> unit (** [set t k v] replaces the contents of [k] by [v] in [t]. If [k] is not already defined in [t], create a fresh binding. Raise [Invalid_argument] if [k] is the {{!Irmin.Path.S.empty} empty path}. *) - val test_and_set : - t -> key -> test:value option -> set:value option -> bool Lwt.t + val test_and_set : t -> key -> test:value option -> set:value option -> bool (** [test_and_set t key ~test ~set] sets [key] to [set] only if the current value of [key] is [test] and in that case returns [true]. If the current value of [key] is different, it returns [false]. [None] means that the @@ -44,32 +43,28 @@ module type S = sig {b Note:} The operation is guaranteed to be atomic. *) - val remove : t -> key -> unit Lwt.t + val remove : t -> key -> unit (** [remove t k] remove the key [k] in [t]. *) - val list : t -> key list Lwt.t + val list : t -> key list (** [list t] it the list of keys in [t]. *) type watch (** The type of watch handlers. *) val watch : - t -> - ?init:(key * value) list -> - (key -> value diff -> unit Lwt.t) -> - watch Lwt.t + t -> ?init:(key * value) list -> (key -> value diff -> unit) -> watch (** [watch t ?init f] adds [f] to the list of [t]'s watch handlers and returns the watch handler to be used with {!unwatch}. [init] is the optional initial values. It is more efficient to use {!watch_key} to watch only a single given key.*) - val watch_key : - t -> key -> ?init:value -> (value diff -> unit Lwt.t) -> watch Lwt.t + val watch_key : t -> key -> ?init:value -> (value diff -> unit) -> watch (** [watch_key t k ?init f] adds [f] to the list of [t]'s watch handlers for the key [k] and returns the watch handler to be used with {!unwatch}. [init] is the optional initial value of the key. *) - val unwatch : t -> watch -> unit Lwt.t + val unwatch : t -> watch -> unit (** [unwatch t w] removes [w] from [t]'s watch handlers. *) include Clearable with type _ t := t diff --git a/src/irmin/backend.ml b/src/irmin/backend.ml index 4b9f981b7f..78492d9e23 100644 --- a/src/irmin/backend.ml +++ b/src/irmin/backend.ml @@ -99,11 +99,8 @@ module type S = sig val batch : t -> - (read_write Contents.t -> - read_write Node.t -> - read_write Commit.t -> - 'a Lwt.t) -> - 'a Lwt.t + (read_write Contents.t -> read_write Node.t -> read_write Commit.t -> 'a) -> + 'a (** A getter from repo to backend stores in rw mode. *) val branch_t : t -> Branch.t @@ -114,6 +111,6 @@ module type S = sig module Remote : sig include Remote.S with type commit = Commit.key and type branch = Branch.key - val v : Repo.t -> t Lwt.t + val v : Repo.t -> t end end diff --git a/src/irmin/commit.ml b/src/irmin/commit.ml index da05c48173..d1b485527b 100644 --- a/src/irmin/commit.ml +++ b/src/irmin/commit.ml @@ -158,28 +158,27 @@ struct let batch (n, s) f = N.batch n (fun n -> S.batch s (fun s -> f (n, s))) let close (n, s) = - let* () = N.close n in - let+ () = S.close s in - () + N.close n; + S.close s let merge_node (t, _) = Merge.f (N.merge t) let pp_key = Type.pp Key.t let err_not_found k = Fmt.kstr invalid_arg "Commit.get: %a not found" pp_key k let get (_, t) k = - S.find t k >>= function None -> err_not_found k | Some v -> Lwt.return v + match S.find t k with None -> err_not_found k | Some v -> v let empty_if_none (n, _) = function | None -> N.add n (N.Val.empty ()) - | Some node -> Lwt.return node + | Some node -> node let equal_key = Type.(unstage (equal Key.t)) let equal_opt_keys = Type.(unstage (equal (option Key.t))) let merge_commit info t ~old k1 k2 = [%log.debug "Commit.merge %a %a" pp_key k1 pp_key k2]; - let* v1 = get t k1 in - let* v2 = get t k2 in + let v1 = get t k1 in + let v2 = get t k2 in if List.mem ~equal:equal_key k1 (Val.parents v2) then Merge.ok k2 else if List.mem ~equal:equal_key k2 (Val.parents v1) then Merge.ok k1 else @@ -187,12 +186,12 @@ struct assume that there is no common ancestor. Maybe we want to expose this to the user in a more structured way. But maybe that's too much low-level details. *) - let* old = - old () >>= function + let old = + match old () with | Error (`Conflict msg) -> [%log.debug "old: conflict %s" msg]; - Lwt.return_none - | Ok o -> Lwt.return o + None + | Ok o -> o in if equal_opt_keys old (Some k1) then Merge.ok k2 else if equal_opt_keys old (Some k2) then Merge.ok k1 @@ -201,15 +200,15 @@ struct match old with | None -> Merge.ok None | Some old -> - let* vold = get t old in + let vold = get t old in Merge.ok (Some (Some (Val.node vold))) in merge_node t ~old (Some (Val.node v1)) (Some (Val.node v2)) >>=* fun node -> - let* node = empty_if_none t node in + let node = empty_if_none t node in let parents = [ k1; k2 ] in let commit = Val.v ~node ~parents ~info:(info ()) in - let* key = add t commit in + let key = add t commit in Merge.ok key let merge t ~info = Merge.(option (v Key.t (merge_commit info t))) @@ -270,14 +269,14 @@ module History (S : Store) = struct let v t ~node ~parents ~info = let commit = S.Val.v ~node ~parents ~info in - let+ hash = S.add t commit in + let hash = S.add t commit in (hash, commit) let pp_key = Type.pp S.Key.t let parents t c = [%log.debug "parents %a" pp_key c]; - S.find t c >|= function None -> [] | Some c -> S.Val.parents c + match S.find t c with None -> [] | Some c -> S.Val.parents c module U = struct type t = unit [@@deriving irmin] @@ -292,26 +291,24 @@ module History (S : Store) = struct let closure t ~min ~max = [%log.debug "closure"]; let pred = function - | `Commit k -> ( S.find t k >|= function Some r -> edges r | None -> []) - | _ -> Lwt.return_nil + | `Commit k -> ( match S.find t k with Some r -> edges r | None -> []) + | _ -> [] in let min = List.map (fun k -> `Commit k) min in let max = List.map (fun k -> `Commit k) max in - let+ g = Graph.closure ~pred ~min ~max () in + let g = Graph.closure ~pred ~min ~max () in List.fold_left (fun acc -> function `Commit k -> k :: acc | _ -> acc) [] (Graph.vertex g) - let ignore_lwt _ = Lwt.return_unit - - let iter t ~min ~max ?(commit = ignore_lwt) ?edge - ?(skip = fun _ -> Lwt.return_false) ?(rev = true) () = + let iter t ~min ~max ?(commit = ignore) ?edge ?(skip = fun _ -> false) + ?(rev = true) () = let max = List.map (fun x -> `Commit x) max in let min = List.map (fun x -> `Commit x) min in let node = function `Commit x -> commit x | _ -> assert false in let skip = function `Commit x -> skip x | _ -> assert false in let pred = function - | `Commit k -> parents t k >|= List.map (fun x -> `Commit x) + | `Commit k -> parents t k |> List.map (fun x -> `Commit x) | _ -> assert false in let edge = @@ -336,7 +333,7 @@ module History (S : Store) = struct module KHashtbl = Hashtbl.Make (K) let read_parents t commit = - S.find t commit >|= function + match S.find t commit with | None -> KSet.empty | Some c -> KSet.of_list (S.Val.parents c) @@ -367,7 +364,7 @@ module History (S : Store) = struct KSet.iter (add_todo 0) init; let rec aux seen = match check () with - | (`Too_many_lcas | `Max_depth_reached) as x -> Lwt.return (Error x) + | (`Too_many_lcas | `Max_depth_reached) as x -> Error x | `Stop -> return () | `Continue -> ( match unqueue todo seen with @@ -376,7 +373,7 @@ module History (S : Store) = struct (* Log.debug "lca %d: %s.%d %a" !lca_calls (pp_key commit) depth force (pp ()); *) let seen = KSet.add commit seen in - let* parents = read_parents t commit in + let parents = read_parents t commit in let () = f depth commit parents in let parents = KSet.diff parents seen in KSet.iter (add_todo (depth + 1)) parents; @@ -545,29 +542,28 @@ module History (S : Store) = struct let lcas t ?(max_depth = max_int) ?(n = max_int) c1 c2 = incr lca_calls; - if max_depth < 0 then Lwt.return (Error `Max_depth_reached) - else if n <= 0 then Lwt.return (Error `Too_many_lcas) - else if equal_keys c1 c2 then Lwt.return (Ok [ c1 ]) + if max_depth < 0 then Error `Max_depth_reached + else if n <= 0 then Error `Too_many_lcas + else if equal_keys c1 c2 then Ok [ c1 ] else let init = KSet.of_list [ c1; c2 ] in let s = empty_state c1 c2 in let check () = check ~max_depth ~n s in let pp () = pp_state s in - let return () = Lwt.return (Ok (lcas s)) in + let return () = Ok (lcas s) in let t0 = Sys.time () in - Lwt.finalize + Fun.protect (fun () -> traverse_bfs t ~f:(update_parents s) ~pp ~check ~init ~return) - (fun () -> + ~finally:(fun () -> let t1 = Sys.time () -. t0 in - [%log.debug "lcas %d: depth=%d time=%.4fs" !lca_calls s.depth t1]; - Lwt.return_unit) + [%log.debug "lcas %d: depth=%d time=%.4fs" !lca_calls s.depth t1]) let rec three_way_merge t ~info ?max_depth ?n c1 c2 = [%log.debug "3-way merge between %a and %a" pp_key c1 pp_key c2]; if equal_keys c1 c2 then Merge.ok c1 else - let* lcas = lcas t ?max_depth ?n c1 c2 in + let lcas = lcas t ?max_depth ?n c1 c2 in let old () = match lcas with | Error `Too_many_lcas -> Merge.conflict "Too many lcas" @@ -592,7 +588,7 @@ module History (S : Store) = struct let lca_aux t ~info ?max_depth ?n c1 c2 = if equal_keys c1 c2 then Merge.ok (Some c1) else - lcas t ?max_depth ?n c1 c2 >>= function + match lcas t ?max_depth ?n c1 c2 with | Error `Too_many_lcas -> Merge.conflict "Too many lcas" | Error `Max_depth_reached -> Merge.conflict "Max depth reached" | Ok [] -> Merge.ok None (* no common ancestor *) @@ -601,7 +597,7 @@ module History (S : Store) = struct let rec aux acc = function | [] -> Merge.ok (Some acc) | c :: cs -> ( - three_way_merge t ~info ?max_depth ?n acc c >>= function + match three_way_merge t ~info ?max_depth ?n acc c with | Error (`Conflict _) -> Merge.ok None | Ok acc -> aux acc cs) in diff --git a/src/irmin/commit_intf.ml b/src/irmin/commit_intf.ml index 7b0eddc57b..4491bba069 100644 --- a/src/irmin/commit_intf.ml +++ b/src/irmin/commit_intf.ml @@ -147,10 +147,10 @@ module type History = sig node:node_key -> parents:commit_key list -> info:info -> - (commit_key * v) Lwt.t + commit_key * v (** Create a new commit. *) - val parents : [> read ] t -> commit_key -> commit_key list Lwt.t + val parents : [> read ] t -> commit_key -> commit_key list (** Get the commit parents. Commits form a append-only, fully functional, partial-order @@ -166,7 +166,7 @@ module type History = sig ?n:int -> commit_key -> commit_key -> - (commit_key list, [ `Max_depth_reached | `Too_many_lcas ]) result Lwt.t + (commit_key list, [ `Max_depth_reached | `Too_many_lcas ]) result (** Find the lowest common ancestors {{:http://en.wikipedia.org/wiki/Lowest_common_ancestor} lca} between two commits. *) @@ -177,7 +177,7 @@ module type History = sig ?max_depth:int -> ?n:int -> commit_key list -> - (commit_key option, Merge.conflict) result Lwt.t + (commit_key option, Merge.conflict) result (** Compute the lowest common ancestors ancestor of a list of commits by recursively calling {!lcas} and merging the results. @@ -192,14 +192,11 @@ module type History = sig ?n:int -> commit_key -> commit_key -> - (commit_key, Merge.conflict) result Lwt.t + (commit_key, Merge.conflict) result (** Compute the {!lcas} of the two commit and 3-way merge the result. *) val closure : - [> read ] t -> - min:commit_key list -> - max:commit_key list -> - commit_key list Lwt.t + [> read ] t -> min:commit_key list -> max:commit_key list -> commit_key list (** Same as {{!Node.Graph.closure} Node.Graph.closure} but for the history graph. *) @@ -207,12 +204,12 @@ module type History = sig [> read ] t -> min:commit_key list -> max:commit_key list -> - ?commit:(commit_key -> unit Lwt.t) -> - ?edge:(commit_key -> commit_key -> unit Lwt.t) -> - ?skip:(commit_key -> bool Lwt.t) -> + ?commit:(commit_key -> unit) -> + ?edge:(commit_key -> commit_key -> unit) -> + ?skip:(commit_key -> bool) -> ?rev:bool -> unit -> - unit Lwt.t + unit (** Same as {{!Node.Graph.iter} Node.Graph.iter} but for traversing the history graph. *) end diff --git a/src/irmin/content_addressable.ml b/src/irmin/content_addressable.ml index aa7b506b5c..c4616a40fb 100644 --- a/src/irmin/content_addressable.ml +++ b/src/irmin/content_addressable.ml @@ -19,7 +19,6 @@ include Content_addressable_intf module Make (AO : Append_only.Maker) (K : Hash.S) (V : Type.S) = struct include AO (K) (V) - open Lwt.Infix module H = Hash.Typed (K) (V) let hash = H.hash @@ -27,20 +26,21 @@ module Make (AO : Append_only.Maker) (K : Hash.S) (V : Type.S) = struct let equal_hash = Type.(unstage (equal K.t)) let find t k = - find t k >>= function - | None -> Lwt.return_none + match find t k with + | None -> None | Some v as r -> let k' = hash v in - if equal_hash k k' then Lwt.return r + if equal_hash k k' then r else - Fmt.kstr Lwt.fail_invalid_arg "corrupted value: got %a, expecting %a" - pp_key k' pp_key k + Fmt.kstr invalid_arg "corrupted value: got %a, expecting %a" pp_key k' + pp_key k let unsafe_add t k v = add t k v let add t v = let k = hash v in - add t k v >|= fun () -> k + add t k v; + k end module Check_closed (CA : Maker) (K : Hash.S) (V : Type.S) = struct @@ -73,11 +73,11 @@ module Check_closed (CA : Maker) (K : Hash.S) (V : Type.S) = struct S.batch t.t (fun w -> f { t = w; closed = t.closed }) let v conf = - let+ t = S.v conf in + let t = S.v conf in { closed = ref false; t } let close t = - if !(t.closed) then Lwt.return_unit + if !(t.closed) then () else ( t.closed := true; S.close t.t) diff --git a/src/irmin/content_addressable_intf.ml b/src/irmin/content_addressable_intf.ml index 1c0fe4a1e4..08d22af813 100644 --- a/src/irmin/content_addressable_intf.ml +++ b/src/irmin/content_addressable_intf.ml @@ -24,11 +24,11 @@ module type S = sig include Read_only.S (** @inline *) - val add : [> write ] t -> value -> key Lwt.t + val add : [> write ] t -> value -> key (** Write the contents of a value to the store. It's the responsibility of the content-addressable store to generate a consistent key. *) - val unsafe_add : [> write ] t -> key -> value -> unit Lwt.t + val unsafe_add : [> write ] t -> key -> value -> unit (** Same as {!add} but allows specifying the key directly. The backend might choose to discard that key and/or can be corrupt if the key scheme is not consistent. *) diff --git a/src/irmin/contents.ml b/src/irmin/contents.ml index 9cc3126f99..4e8193a142 100644 --- a/src/irmin/contents.ml +++ b/src/irmin/contents.ml @@ -221,11 +221,8 @@ struct module Hash = Hash.Typed (H) (C) include S - let read_opt t = function None -> Lwt.return_none | Some k -> find t k - - let add_opt t = function - | None -> Lwt.return_none - | Some v -> add t v >>= Lwt.return_some + let read_opt t = function None -> None | Some k -> find t k + let add_opt t = function None -> None | Some v -> Some (add t v) let merge t = Merge.like_lwt Type.(option Key.t) Val.merge (read_opt t) (add_opt t) diff --git a/src/irmin/dot.ml b/src/irmin/dot.ml index 4be8bd91d0..5fcfaf9698 100644 --- a/src/irmin/dot.ml +++ b/src/irmin/dot.ml @@ -32,7 +32,7 @@ module type S = sig ?full:bool -> date:(int64 -> string) -> Buffer.t -> - unit Lwt.t + unit end exception Utf8_failure @@ -68,7 +68,7 @@ module Make (S : Store.Generic_key.S) = struct (match depth with None -> "" | Some d -> string_of_int d) html (match full with None -> "" | Some b -> string_of_bool b)]; - let* slice = S.Repo.export ?full ?depth (S.repo t) in + let slice = S.Repo.export ?full ?depth (S.repo t) in let vertex = Hashtbl.create 102 in let add_vertex v l = Hashtbl.add vertex v l in let mem_vertex v = Hashtbl.mem vertex v in @@ -152,18 +152,10 @@ module Make (S : Store.Generic_key.S) = struct let contents = ref [] in let nodes = ref [] in let commits = ref [] in - let* () = - Slice.iter slice (function - | `Contents c -> - contents := c :: !contents; - Lwt.return_unit - | `Node n -> - nodes := n :: !nodes; - Lwt.return_unit - | `Commit c -> - commits := c :: !commits; - Lwt.return_unit) - in + Slice.iter slice (function + | `Contents c -> contents := c :: !contents + | `Node n -> nodes := n :: !nodes + | `Commit c -> commits := c :: !commits); List.iter (fun (k, c) -> add_vertex (`Contents k) [ `Shape `Box; label_of_contents k c ]) @@ -203,24 +195,22 @@ module Make (S : Store.Generic_key.S) = struct add_edge (`Commit k) [ `Style `Dashed ] (`Node node_hash)) !commits; let branch_t = S.Backend.Repo.branch_t (S.repo t) in - let* bs = Branch.list branch_t in - let+ () = - Lwt_list.iter_s - (fun r -> - Branch.find branch_t r >|= function - | None -> () - | Some k -> - let k = Commit.Key.to_hash k in - add_vertex (`Branch r) - [ `Shape `Plaintext; label_of_tag r; `Style `Filled ]; - add_edge (`Branch r) [ `Style `Bold ] (`Commit k)) - bs - in + let bs = Branch.list branch_t in + List.iter + (fun r -> + match Branch.find branch_t r with + | None -> () + | Some k -> + let k = Commit.Key.to_hash k in + add_vertex (`Branch r) + [ `Shape `Plaintext; label_of_tag r; `Style `Filled ]; + add_edge (`Branch r) [ `Style `Bold ] (`Commit k)) + bs; let vertex = Hashtbl.fold (fun k v acc -> (k, v) :: acc) vertex [] in fun ppf -> Graph.output ppf vertex !edges name let output_buffer t ?html ?depth ?full ~date buf = - let+ fprintf = fprintf t ?depth ?full ?html ~date "graph" in + let fprintf = fprintf t ?depth ?full ?html ~date "graph" in let ppf = Format.formatter_of_buffer buf in fprintf ppf end diff --git a/src/irmin/dot.mli b/src/irmin/dot.mli index aa8f903461..e7fc2b4afe 100644 --- a/src/irmin/dot.mli +++ b/src/irmin/dot.mli @@ -28,7 +28,7 @@ module type S = sig ?full:bool -> date:(int64 -> string) -> Buffer.t -> - unit Lwt.t + unit (** [output_buffer t ?html ?depth ?full buf] outputs the Graphviz representation of [t] in the buffer [buf]. diff --git a/src/irmin/dune b/src/irmin/dune index 938a2ff5ec..2e031731df 100644 --- a/src/irmin/dune +++ b/src/irmin/dune @@ -10,7 +10,7 @@ jsonm logs logs.fmt - lwt + eio mtime ocamlgraph uri diff --git a/src/irmin/import.ml b/src/irmin/import.ml index 814f31812a..a5e2e3b39b 100644 --- a/src/irmin/import.ml +++ b/src/irmin/import.ml @@ -21,13 +21,6 @@ type read = Perms.read type write = Perms.write type read_write = Perms.read_write -(** {2 Lwt syntax} *) - -include Lwt.Syntax - -let ( >>= ) = Lwt.Infix.( >>= ) -let ( >|= ) = Lwt.Infix.( >|= ) - (** {2 Dependency extensions} *) module Option = struct diff --git a/src/irmin/indexable.ml b/src/irmin/indexable.ml index 5f833bea85..7ab48eff82 100644 --- a/src/irmin/indexable.ml +++ b/src/irmin/indexable.ml @@ -40,8 +40,11 @@ struct let to_hash x = x end - let index _ h = Lwt.return_some h - let unsafe_add t h v = unsafe_add t h v >|= fun () -> h + let index _ h = Some h + + let unsafe_add t h v = + unsafe_add t h v; + h end module Check_closed_store (CA : S) = struct @@ -67,7 +70,7 @@ module Check_closed_store (CA : S) = struct (get_if_open_exn t |> CA.batch) (fun w -> f { t = w; closed = t.closed }) let close t = - if !(t.closed) then Lwt.return_unit + if !(t.closed) then () else ( t.closed := true; CA.close t.t) @@ -78,6 +81,6 @@ module Check_closed (M : Maker) (Hash : Hash.S) (Value : Type.S) = struct include Check_closed_store (CA) let v conf = - let+ t = CA.v conf in + let t = CA.v conf in { closed = ref false; t } end diff --git a/src/irmin/indexable_intf.ml b/src/irmin/indexable_intf.ml index e7c084e8a2..03f4e1d9c2 100644 --- a/src/irmin/indexable_intf.ml +++ b/src/irmin/indexable_intf.ml @@ -25,15 +25,15 @@ module type S_without_key_impl = sig type hash (** The type of hashes of [value]. *) - val add : [> write ] t -> value -> key Lwt.t + val add : [> write ] t -> value -> key (** Write the contents of a value to the store, and obtain its key. *) - val unsafe_add : [> write ] t -> hash -> value -> key Lwt.t + val unsafe_add : [> write ] t -> hash -> value -> key (** Same as {!add} but allows specifying the value's hash directly. The backend might choose to discard that hash and/or can be corrupt if the hash is not consistent. *) - val index : [> read ] t -> hash -> key option Lwt.t + val index : [> read ] t -> hash -> key option (** Indexing maps the hash of a value to a corresponding key of that value in the store. For stores that are addressed by hashes directly, this is typically [fun _t h -> Lwt.return (Key.of_hash h)]; for stores with more diff --git a/src/irmin/irmin.ml b/src/irmin/irmin.ml index 5a3efa3e09..c932beff32 100644 --- a/src/irmin/irmin.ml +++ b/src/irmin/irmin.ml @@ -125,18 +125,18 @@ module Maker_generic_key (Backend : Maker_generic_key_args) = struct f contents_t node_t commit_t let v config = - let* contents = Contents.Backend.v config in - let* nodes = Node.Backend.v config in - let* commits = Commit.Backend.v config in + let contents = Contents.Backend.v config in + let nodes = Node.Backend.v config in + let commits = Commit.Backend.v config in let nodes = (contents, nodes) in let commits = (nodes, commits) in - let+ branch = Branch.v config in + let branch = Branch.v config in { contents; nodes; commits; branch; config } let close t = - Contents.Backend.close t.contents >>= fun () -> - Node.Backend.close (snd t.nodes) >>= fun () -> - Commit.Backend.close (snd t.commits) >>= fun () -> + Contents.Backend.close t.contents; + Node.Backend.close (snd t.nodes); + Commit.Backend.close (snd t.commits); Branch.close t.branch end end diff --git a/src/irmin/lock.ml b/src/irmin/lock.ml index 6cd3f5a0ab..aef730212a 100644 --- a/src/irmin/lock.ml +++ b/src/irmin/lock.ml @@ -21,7 +21,7 @@ module type S = sig type t val v : unit -> t - val with_lock : t -> key -> (unit -> 'a Lwt.t) -> 'a Lwt.t + val with_lock : t -> key -> (unit -> 'a) -> 'a val stats : t -> int end @@ -36,31 +36,30 @@ module Make (K : Type.S) = struct module KHashtbl = Hashtbl.Make (K) type key = K.t - type t = { global : Lwt_mutex.t; locks : Lwt_mutex.t KHashtbl.t } + type t = { global : Eio.Mutex.t; locks : Eio.Mutex.t KHashtbl.t } - let v () = { global = Lwt_mutex.create (); locks = KHashtbl.create 1024 } + let v () = { global = Eio.Mutex.create (); locks = KHashtbl.create 1024 } let stats t = KHashtbl.length t.locks let lock t key () = let lock = try KHashtbl.find t.locks key with Not_found -> - let lock = Lwt_mutex.create () in + let lock = Eio.Mutex.create () in KHashtbl.add t.locks key lock; lock in - Lwt.return lock + lock let unlock t key () = - let () = - if KHashtbl.mem t.locks key then - let lock = KHashtbl.find t.locks key in - if Lwt_mutex.is_empty lock then KHashtbl.remove t.locks key - in - Lwt.return_unit + if KHashtbl.mem t.locks key then + let lock = KHashtbl.find t.locks key in + (* TODO: is_empty not is_locked *) + if Eio.Mutex.try_lock lock then KHashtbl.remove t.locks key let with_lock t k fn = - let* lock = Lwt_mutex.with_lock t.global (lock t k) in - let* r = Lwt_mutex.with_lock lock fn in - Lwt_mutex.with_lock t.global (unlock t k) >>= fun () -> Lwt.return r + let lock = Eio.Mutex.use_rw ~protect:true t.global (lock t k) in + let r = Eio.Mutex.use_rw ~protect:true lock fn in + Eio.Mutex.use_rw ~protect:true t.global (unlock t k); + r end diff --git a/src/irmin/lock.mli b/src/irmin/lock.mli index 718b6db22b..013e0944cd 100644 --- a/src/irmin/lock.mli +++ b/src/irmin/lock.mli @@ -26,7 +26,7 @@ module type S = sig val v : unit -> t (** Create a lock manager. *) - val with_lock : t -> key -> (unit -> 'a Lwt.t) -> 'a Lwt.t + val with_lock : t -> key -> (unit -> 'a) -> 'a (** [with_lock t k f] executes [f ()] while holding the exclusive lock associated to the key [k]. *) diff --git a/src/irmin/mem/irmin_mem.ml b/src/irmin/mem/irmin_mem.ml index e69eefa1af..95d5a73150 100644 --- a/src/irmin/mem/irmin_mem.ml +++ b/src/irmin/mem/irmin_mem.ml @@ -52,16 +52,15 @@ module Read_only (K : Irmin.Type.S) (V : Irmin.Type.S) = struct t | Some t -> t in - Lwt.return t + t let clear t = [%log.debug "clear"]; - t.t <- KMap.empty; - Lwt.return_unit + t.t <- KMap.empty let close _ = [%log.debug "close"]; - Lwt.return_unit + () let cast t = (t :> read_write t) let batch t f = f (cast t) @@ -69,11 +68,11 @@ module Read_only (K : Irmin.Type.S) (V : Irmin.Type.S) = struct let find { t; _ } key = [%log.debug "find %a" pp_key key]; - try Lwt.return_some (KMap.find key t) with Not_found -> Lwt.return_none + try Some (KMap.find key t) with Not_found -> None let mem { t; _ } key = [%log.debug "mem %a" pp_key key]; - Lwt.return (KMap.mem key t) + KMap.mem key t end module Append_only (K : Irmin.Type.S) (V : Irmin.Type.S) = struct @@ -81,8 +80,7 @@ module Append_only (K : Irmin.Type.S) (V : Irmin.Type.S) = struct let add t key value = [%log.debug "add -> %a" pp_key key]; - t.t <- KMap.add key value t.t; - Lwt.return_unit + t.t <- KMap.add key value t.t end module Atomic_write (K : Irmin.Type.S) (V : Irmin.Type.S) = struct @@ -99,10 +97,13 @@ module Atomic_write (K : Irmin.Type.S) (V : Irmin.Type.S) = struct let lock = L.v () let v config = - let* t = RO.v config in - Lwt.return { t; w = watches; lock } + let t = RO.v config in + { t; w = watches; lock } + + let close t = + W.clear t.w; + RO.close t.t - let close t = W.clear t.w >>= fun () -> RO.close t.t let find t = RO.find t.t let mem t = RO.mem t.t let watch_key t = W.watch_key t.w @@ -111,33 +112,26 @@ module Atomic_write (K : Irmin.Type.S) (V : Irmin.Type.S) = struct let list t = [%log.debug "list"]; - RO.KMap.fold (fun k _ acc -> k :: acc) t.t.RO.t [] |> Lwt.return + RO.KMap.fold (fun k _ acc -> k :: acc) t.t.RO.t [] let set t key value = [%log.debug "update"]; - let* () = - L.with_lock t.lock key (fun () -> - t.t.RO.t <- RO.KMap.add key value t.t.RO.t; - Lwt.return_unit) - in + L.with_lock t.lock key (fun () -> + t.t.RO.t <- RO.KMap.add key value t.t.RO.t); W.notify t.w key (Some value) let remove t key = [%log.debug "remove"]; - let* () = - L.with_lock t.lock key (fun () -> - t.t.RO.t <- RO.KMap.remove key t.t.RO.t; - Lwt.return_unit) - in + L.with_lock t.lock key (fun () -> t.t.RO.t <- RO.KMap.remove key t.t.RO.t); W.notify t.w key None let equal_v_opt = Irmin.Type.(unstage (equal (option V.t))) let test_and_set t key ~test ~set = [%log.debug "test_and_set"]; - let* updated = + let updated = L.with_lock t.lock key (fun () -> - let+ v = find t key in + let v = find t key in if equal_v_opt test v then let () = match set with @@ -147,10 +141,12 @@ module Atomic_write (K : Irmin.Type.S) (V : Irmin.Type.S) = struct true else false) in - let+ () = if updated then W.notify t.w key set else Lwt.return_unit in + if updated then W.notify t.w key set; updated - let clear t = W.clear t.w >>= fun () -> RO.clear t.t + let clear t = + W.clear t.w; + RO.clear t.t end let config () = Conf.empty Conf.spec diff --git a/src/irmin/merge.ml b/src/irmin/merge.ml index 67435d80e9..6329aeddd5 100644 --- a/src/irmin/merge.ml +++ b/src/irmin/merge.ml @@ -22,9 +22,9 @@ let src = Logs.Src.create "irmin.merge" ~doc:"Irmin merging" module Log = (val Logs.src_log src : Logs.LOG) type conflict = [ `Conflict of string ] -type 'a promise = unit -> ('a option, conflict) result Lwt.t +type 'a promise = unit -> ('a option, conflict) result -let promise t : 'a promise = fun () -> Lwt.return (Ok (Some t)) +let promise t : 'a promise = fun () -> Ok (Some t) let memo fn = let r = ref None in @@ -32,11 +32,11 @@ let memo fn = match !r with | Some x -> x | None -> - let* x = fn () in - r := Some (Lwt.return x); - Lwt.return x + let x = fn () in + r := Some x; + x -type 'a f = old:'a promise -> 'a -> 'a -> ('a, conflict) result Lwt.t +type 'a f = old:'a promise -> 'a -> 'a -> ('a, conflict) result type 'a t = 'a Type.t * 'a f let v t f = (t, f) @@ -46,25 +46,25 @@ let conflict fmt = ksprintf (fun msg -> [%log.debug "conflict: %s" msg]; - Lwt.return (Error (`Conflict msg))) + Error (`Conflict msg)) fmt -let bind x f = x >>= function Error e -> Lwt.return (Error e) | Ok x -> f x -let map f x = x >|= function Error _ as x -> x | Ok x -> Ok (f x) +let bind x f = match x with Error e -> Error e | Ok x -> f x +let map f x = match x with Error _ as x -> x | Ok x -> Ok (f x) let map_promise f t () = - t () >|= function + match t () with | Error _ as x -> x | Ok None -> Ok None | Ok (Some a) -> Ok (Some (f a)) let bind_promise t f () = - t () >>= function - | Error e -> Lwt.return (Error e) - | Ok None -> Lwt.return (Ok None) + match t () with + | Error e -> Error e + | Ok None -> Ok None | Ok (Some a) -> f a () -let ok x = Lwt.return (Ok x) +let ok x = Ok x module Infix = struct let ( >>=* ) = bind @@ -101,7 +101,7 @@ let seq = function | (t, _) :: _ as ts -> ( t, fun ~old v1 v2 -> - Lwt_list.fold_left_s + List.fold_left (fun acc (_, merge) -> match acc with Ok x -> ok x | Error _ -> merge ~old v1 v2) (Error (`Conflict "nothing to merge")) @@ -114,7 +114,7 @@ let option (type a) ((a, t) : a t) : a option t = ( dt, fun ~old t1 t2 -> [%log.debug "some %a | %a" pp t1 pp t2]; - f (default Type.(option a)) ~old t1 t2 >>= function + match f (default Type.(option a)) ~old t1 t2 with | Ok x -> ok x | Error _ -> ( match (t1, t2) with @@ -144,7 +144,7 @@ let pair (da, a) (db, b) = ( dt, fun ~old x y -> [%log.debug "pair %a | %a" pp x pp y]; - (snd (default dt)) ~old x y >>= function + match (snd (default dt)) ~old x y with | Ok x -> ok x | Error _ -> let (a1, b1), (a2, b2) = (x, y) in @@ -159,7 +159,7 @@ let triple (da, a) (db, b) (dc, c) = ( dt, fun ~old x y -> [%log.debug "triple %a | %a" pp x pp y]; - (snd (default dt)) ~old x y >>= function + match (snd (default dt)) ~old x y with | Ok x -> ok x | Error _ -> let (a1, b1, c1), (a2, b2, c2) = (x, y) in @@ -180,9 +180,9 @@ let merge_elt merge_v old key vs = | `Both (v1, v2) -> (Some v1, Some v2) in let old () = old key in - merge_v key ~old v1 v2 >>= function - | Error (`Conflict msg) -> Lwt.fail (C msg) - | Ok x -> Lwt.return x + match merge_v key ~old v1 v2 with + | Error (`Conflict msg) -> raise (C msg) + | Ok x -> x (* assume l1 and l2 are key-sorted *) let alist_iter2 compare_k f l1 l2 = @@ -209,23 +209,19 @@ let alist_iter2 compare_k f l1 l2 = let alist_iter2_lwt compare_k f l1 l2 = let l3 = ref [] in alist_iter2 compare_k (fun left right -> l3 := f left right :: !l3) l1 l2; - Lwt_list.iter_p Fun.id (List.rev !l3) + List.iter Fun.id (List.rev !l3) (* DO NOT assume l1 and l2 are key-sorted *) let alist_merge_lwt compare_k f l1 l2 = - let open Lwt in let l3 = ref [] in let sort l = List.sort (fun (x, _) (y, _) -> compare_k x y) l in let l1 = sort l1 in let l2 = sort l2 in let f key data = - f key data >>= function - | None -> return_unit - | Some v -> - l3 := (key, v) :: !l3; - return_unit + match f key data with None -> () | Some v -> l3 := (key, v) :: !l3 in - alist_iter2_lwt compare_k f l1 l2 >>= fun () -> return !l3 + alist_iter2_lwt compare_k f l1 l2; + !l3 let alist dx dy merge_v = let pair = Type.pair dx dy in @@ -248,10 +244,9 @@ let alist dx dy merge_v = Some old in let merge_v k = f (merge_v k) in - Lwt.catch - (fun () -> - alist_merge_lwt compare_dx (merge_elt merge_v old) x y >>= ok) - (function C msg -> conflict "%s" msg | e -> Lwt.fail e) ) + try ok @@ alist_merge_lwt compare_dx (merge_elt merge_v old) x y with + | C msg -> conflict "%s" msg + | e -> raise e ) module MultiSet (K : sig include Set.OrderedType @@ -322,16 +317,16 @@ struct let iter2 f m1 m2 = let m3 = ref [] in iter2 (fun key data -> m3 := f key data :: !m3) m1 m2; - Lwt_list.iter_p (fun b -> b >>= fun () -> Lwt.return_unit) (List.rev !m3) + (* Check iter_p *) + List.iter (fun b -> b ()) (List.rev !m3) let merge_maps f m1 m2 = let l3 = ref [] in - let f key data = - f key data >|= function None -> () | Some v -> l3 := (key, v) :: !l3 + let f key data () = + match f key data with None -> () | Some v -> l3 := (key, v) :: !l3 in - iter2 f m1 m2 >>= fun () -> - let m3 = of_alist !l3 in - Lwt.return m3 + iter2 f m1 m2; + of_alist !l3 let merge dv (merge_v : K.t -> 'a option t) = let pp ppf m = Type.(pp (list (pair K.t dv))) ppf @@ M.bindings m in @@ -339,20 +334,19 @@ struct ( t dv, fun ~old m1 m2 -> [%log.debug "assoc %a | %a" pp m1 pp m2]; - Lwt.catch - (fun () -> - let old key = - old () >>=* function - | None -> ok None - | Some old -> - [%log.debug "assoc old=%a" pp old]; - let old = - try Some (M.find key old) with Not_found -> None - in - ok (Some old) - in - merge_maps (merge_elt merge_v old) m1 m2 >>= ok) - (function C msg -> conflict "%s" msg | e -> Lwt.fail e) ) + try + let old key = + old () >>=* function + | None -> ok None + | Some old -> + [%log.debug "assoc old=%a" pp old]; + let old = try Some (M.find key old) with Not_found -> None in + ok (Some old) + in + ok @@ merge_maps (merge_elt merge_v old) m1 m2 + with + | C msg -> conflict "%s" msg + | e -> raise e ) end let like da t a_to_b b_to_a = @@ -368,23 +362,22 @@ let like da t a_to_b b_to_a = in seq [ default da; (da, merge) ] -let like_lwt (type a b) da (t : b t) (a_to_b : a -> b Lwt.t) - (b_to_a : b -> a Lwt.t) : a t = +let like_lwt (type a b) da (t : b t) (a_to_b : a -> b) (b_to_a : b -> a) : a t = let pp = Type.pp da in let merge ~old a1 a2 = [%log.debug "biject' %a | %a" pp a1 pp a2]; try - let* b1 = a_to_b a1 in - let* b2 = a_to_b a2 in + let b1 = a_to_b a1 in + let b2 = a_to_b a2 in let old = memo (fun () -> bind (old ()) @@ function | None -> ok None | Some a -> - let+ b = a_to_b a in + let b = a_to_b a in Ok (Some b)) in - bind ((f t) ~old b1 b2) @@ fun b3 -> b_to_a b3 >>= ok + bind ((f t) ~old b1 b2) @@ fun b3 -> ok (b_to_a b3) with Not_found -> conflict "biject'" in seq [ default da; (da, merge) ] @@ -409,7 +402,7 @@ let counter = let with_conflict rewrite (d, f) = let f ~old x y = - f ~old x y >>= function + match f ~old x y with | Error (`Conflict msg) -> conflict "%s" (rewrite msg) | Ok x -> ok x in diff --git a/src/irmin/merge.mli b/src/irmin/merge.mli index 2ec7b19f34..b1877e61a7 100644 --- a/src/irmin/merge.mli +++ b/src/irmin/merge.mli @@ -19,27 +19,24 @@ type conflict = [ `Conflict of string ] [@@deriving irmin] (** The type for merge errors. *) -val ok : 'a -> ('a, conflict) result Lwt.t +val ok : 'a -> ('a, conflict) result (** Return [Ok x]. *) -val conflict : ('a, unit, string, ('b, conflict) result Lwt.t) format4 -> 'a +val conflict : ('a, unit, string, ('b, conflict) result) format4 -> 'a (** Return [Error (Conflict str)]. *) -val bind : - ('a, 'b) result Lwt.t -> - ('a -> ('c, 'b) result Lwt.t) -> - ('c, 'b) result Lwt.t +val bind : ('a, 'b) result -> ('a -> ('c, 'b) result) -> ('c, 'b) result (** [bind r f] is the merge result which behaves as of the application of the function [f] to the return value of [r]. If [r] fails, [bind r f] also fails, with the same conflict. *) -val map : ('a -> 'c) -> ('a, 'b) result Lwt.t -> ('c, 'b) result Lwt.t +val map : ('a -> 'c) -> ('a, 'b) result -> ('c, 'b) result (** [map f m] maps the result of a merge. This is the same as [bind m (fun x -> ok (f x))]. *) (** {1 Merge Combinators} *) -type 'a promise = unit -> ('a option, conflict) result Lwt.t +type 'a promise = unit -> ('a option, conflict) result (** An ['a] promise is a function which, when called, will eventually return a value type of ['a]. A promise is an optional, lazy and non-blocking value. *) @@ -54,7 +51,7 @@ val bind_promise : 'a promise -> ('a -> 'b promise) -> 'b promise (** [bind_promise a f] is the promise returned by [f] applied to what is promised by [a]. *) -type 'a f = old:'a promise -> 'a -> 'a -> ('a, conflict) result Lwt.t +type 'a f = old:'a promise -> 'a -> 'a -> ('a, conflict) result (** Signature of a merge function. [old] is the value of the least-common ancestor. @@ -84,7 +81,7 @@ val like : 'a Type.t -> 'b t -> ('a -> 'b) -> ('b -> 'a) -> 'a t val with_conflict : (string -> string) -> 'a t -> 'a t (** [with_conflict f m] is [m] with the conflict error message modified by [f]. *) -val like_lwt : 'a Type.t -> 'b t -> ('a -> 'b Lwt.t) -> ('b -> 'a Lwt.t) -> 'a t +val like_lwt : 'a Type.t -> 'b t -> ('a -> 'b) -> ('b -> 'a) -> 'a t (** Same as {{!Merge.biject} biject} but with blocking domain converting functions. *) @@ -206,13 +203,12 @@ module Infix : sig (** {1 Merge Result Combinators} *) val ( >>=* ) : - ('a, conflict) result Lwt.t -> - ('a -> ('b, conflict) result Lwt.t) -> - ('b, conflict) result Lwt.t + ('a, conflict) result -> + ('a -> ('b, conflict) result) -> + ('b, conflict) result (** [>>=*] is {!bind}. *) - val ( >|=* ) : - ('a, conflict) result Lwt.t -> ('a -> 'b) -> ('b, conflict) result Lwt.t + val ( >|=* ) : ('a, conflict) result -> ('a -> 'b) -> ('b, conflict) result (** [>|=*] is {!map}. *) (** {1 Promise Combinators} diff --git a/src/irmin/node.ml b/src/irmin/node.ml index a13a953688..a7b23a4759 100644 --- a/src/irmin/node.ml +++ b/src/irmin/node.ml @@ -471,9 +471,8 @@ struct let batch (c, s) f = C.batch c (fun n -> S.batch s (fun s -> f (n, s))) let close (c, s) = - let* () = C.close c in - let+ () = S.close s in - () + C.close c; + S.close s let rec merge t = let merge_key = @@ -482,12 +481,10 @@ struct in let merge = Val.merge ~contents:C.(merge (fst t)) ~node:merge_key in let read = function - | None -> Lwt.return (Val.empty ()) - | Some k -> ( find t k >|= function None -> Val.empty () | Some v -> v) - in - let add v = - if Val.is_empty v then Lwt.return_none else add t v >>= Lwt.return_some + | None -> Val.empty () + | Some k -> ( match find t k with None -> Val.empty () | Some v -> v) in + let add v = if Val.is_empty v then None else Some (add t v) in Merge.like_lwt [%typ: Key.t option] merge read add end @@ -530,7 +527,7 @@ module Graph (S : Store) = struct let list t n = [%log.debug "steps"]; - S.find t n >|= function None -> [] | Some n -> S.Val.list n + match S.find t n with None -> [] | Some n -> S.Val.list n module U = struct type t = unit [@@deriving irmin] @@ -549,42 +546,38 @@ module Graph (S : Store) = struct let equal_val = Type.(unstage (equal S.Val.t)) let pred t = function - | `Node k -> ( S.find t k >|= function None -> [] | Some v -> edges v) - | _ -> Lwt.return_nil + | `Node k -> ( match S.find t k with None -> [] | Some v -> edges v) + | _ -> [] let closure t ~min ~max = [%log.debug "closure min=%a max=%a" pp_keys min pp_keys max]; let min = List.rev_map (fun x -> `Node x) min in let max = List.rev_map (fun x -> `Node x) max in - let+ g = Graph.closure ~pred:(pred t) ~min ~max () in + let g = Graph.closure ~pred:(pred t) ~min ~max () in List.fold_left (fun acc -> function `Node x -> x :: acc | _ -> acc) [] (Graph.vertex g) - let ignore_lwt _ = Lwt.return_unit - - let iter t ~min ~max ?(node = ignore_lwt) ?(contents = ignore_lwt) ?edge - ?(skip_node = fun _ -> Lwt.return_false) - ?(skip_contents = fun _ -> Lwt.return_false) ?(rev = true) () = + let iter t ~min ~max ?(node = ignore) ?(contents = ignore) ?edge + ?(skip_node = fun _ -> false) ?(skip_contents = fun _ -> false) + ?(rev = true) () = let min = List.rev_map (fun x -> `Node x) min in let max = List.rev_map (fun x -> `Node x) max in let node = function | `Node x -> node x | `Contents c -> contents c - | `Branch _ | `Commit _ -> Lwt.return_unit + | `Branch _ | `Commit _ -> () in let edge = Option.map (fun edge n pred -> - match (n, pred) with - | `Node src, `Node dst -> edge src dst - | _ -> Lwt.return_unit) + match (n, pred) with `Node src, `Node dst -> edge src dst | _ -> ()) edge in let skip = function | `Node x -> skip_node x | `Contents c -> skip_contents c - | _ -> Lwt.return_false + | _ -> false in Graph.iter ~pred:(pred t) ~min ~max ~node ?edge ~skip ~rev () @@ -592,16 +585,16 @@ module Graph (S : Store) = struct let find_step t node step = [%log.debug "contents %a" pp_key node]; - S.find t node >|= function None -> None | Some n -> S.Val.find n step + match S.find t node with None -> None | Some n -> S.Val.find n step let find t node path = [%log.debug "read_node_exn %a %a" pp_key node pp_path path]; let rec aux node path = match Path.decons path with - | None -> Lwt.return_some (`Node node) + | None -> Some (`Node node) | Some (h, tl) -> ( - find_step t node h >>= function - | (None | Some (`Contents _)) as x -> Lwt.return x + match find_step t node h with + | (None | Some (`Contents _)) as x -> x | Some (`Node node) -> aux node tl) in aux node path @@ -611,42 +604,39 @@ module Graph (S : Store) = struct let map_one t node f label = [%log.debug "map_one %a" Type.(pp Path.step_t) label]; let old_key = S.Val.find node label in - let* old_node = + let old_node = match old_key with - | None | Some (`Contents _) -> Lwt.return (S.Val.empty ()) + | None | Some (`Contents _) -> S.Val.empty () | Some (`Node k) -> ( - S.find t k >|= function None -> S.Val.empty () | Some v -> v) + match S.find t k with None -> S.Val.empty () | Some v -> v) in - let* new_node = f old_node in - if equal_val old_node new_node then Lwt.return node + let new_node = f old_node in + if equal_val old_node new_node then node else if S.Val.is_empty new_node then let node = S.Val.remove node label in - if S.Val.is_empty node then Lwt.return (S.Val.empty ()) - else Lwt.return node + if S.Val.is_empty node then S.Val.empty () else node else - let+ k = S.add t new_node in + let k = S.add t new_node in S.Val.add node label (`Node k) let map t node path f = [%log.debug "map %a %a" pp_key node pp_path path]; let rec aux node path = match Path.decons path with - | None -> Lwt.return (f node) + | None -> f node | Some (h, tl) -> map_one t node (fun node -> aux node tl) h in - let* node = - S.find t node >|= function None -> S.Val.empty () | Some n -> n + let node = + match S.find t node with None -> S.Val.empty () | Some n -> n in - aux node path >>= S.add t + aux node path |> S.add t let add t node path n = [%log.debug "add %a %a" pp_key node pp_path path]; match Path.rdecons path with | Some (path, file) -> map t node path (fun node -> S.Val.add node file n) | None -> ( - match n with - | `Node n -> Lwt.return n - | `Contents _ -> failwith "TODO: Node.add") + match n with `Node n -> n | `Contents _ -> failwith "TODO: Node.add") let rdecons_exn path = match Path.rdecons path with @@ -782,7 +772,7 @@ module V1 (N : Generic_key.S with type step = string) = struct let merge = N.merge ~contents ~node in let f ~old x y = let old = Merge.map_promise (fun old -> old.n) old in - let+ r = Merge.f merge ~old x.n y.n in + let r = Merge.f merge ~old x.n y.n in match r with Ok r -> Ok (import r) | Error e -> Error e in Merge.v t f diff --git a/src/irmin/node_intf.ml b/src/irmin/node_intf.ml index 9d9fda43a1..c3dcbd797c 100644 --- a/src/irmin/node_intf.ml +++ b/src/irmin/node_intf.ml @@ -290,28 +290,28 @@ module type Graph = sig [@@deriving irmin] (** The type for store values. *) - val empty : [> write ] t -> node_key Lwt.t + val empty : [> write ] t -> node_key (** The empty node. *) - val v : [> write ] t -> (step * value) list -> node_key Lwt.t + val v : [> write ] t -> (step * value) list -> node_key (** [v t n] is a new node containing [n]. *) - val list : [> read ] t -> node_key -> (step * value) list Lwt.t + val list : [> read ] t -> node_key -> (step * value) list (** [list t n] is the contents of the node [n]. *) - val find : [> read ] t -> node_key -> path -> value option Lwt.t + val find : [> read ] t -> node_key -> path -> value option (** [find t n p] is the contents of the path [p] starting form [n]. *) - val add : [> read_write ] t -> node_key -> path -> value -> node_key Lwt.t + val add : [> read_write ] t -> node_key -> path -> value -> node_key (** [add t n p v] is the node [x] such that [find t x p] is [Some v] and it behaves the same [n] for other operations. *) - val remove : [> read_write ] t -> node_key -> path -> node_key Lwt.t + val remove : [> read_write ] t -> node_key -> path -> node_key (** [remove t n path] is the node [x] such that [find t x] is [None] and it behhaves then same as [n] for other operations. *) val closure : - [> read ] t -> min:node_key list -> max:node_key list -> node_key list Lwt.t + [> read ] t -> min:node_key list -> max:node_key list -> node_key list (** [closure t min max] is the unordered list of nodes [n] reachable from a node of [max] along a path which: (i) either contains no [min] or (ii) it ends with a [min]. @@ -322,14 +322,14 @@ module type Graph = sig [> read ] t -> min:node_key list -> max:node_key list -> - ?node:(node_key -> unit Lwt.t) -> - ?contents:(contents_key -> unit Lwt.t) -> - ?edge:(node_key -> node_key -> unit Lwt.t) -> - ?skip_node:(node_key -> bool Lwt.t) -> - ?skip_contents:(contents_key -> bool Lwt.t) -> + ?node:(node_key -> unit) -> + ?contents:(contents_key -> unit) -> + ?edge:(node_key -> node_key -> unit) -> + ?skip_node:(node_key -> bool) -> + ?skip_contents:(contents_key -> bool) -> ?rev:bool -> unit -> - unit Lwt.t + unit (** [iter t min max node edge skip rev ()] iterates in topological order over the closure of [t]. diff --git a/src/irmin/object_graph.ml b/src/irmin/object_graph.ml index bb47a16371..b3005d9b84 100644 --- a/src/irmin/object_graph.ml +++ b/src/irmin/object_graph.ml @@ -116,11 +116,11 @@ struct let mark key level = Table.add marks key level in let todo = Stack.create () in (* if a branch is in [min], add the commit it is pointing to too. *) - let* min = - Lwt_list.fold_left_s + let min = + List.fold_left (fun acc -> function - | `Branch _ as x -> pred x >|= fun c -> (x :: c) @ acc - | x -> Lwt.return (x :: acc)) + | `Branch _ as x -> (x :: pred x) @ acc + | x -> x :: acc) [] min in let min = Set.of_list min in @@ -128,19 +128,19 @@ struct List.iter (fun k -> Stack.push (Visit (k, 0)) todo) max; let treat key = [%log.debug "TREAT %a" Type.(pp X.t) key]; - node key >>= fun () -> + node key; if not (Set.mem key min) then (* the edge function is optional to prevent an unnecessary computation of the preds .*) match edge with - | None -> Lwt.return_unit + | None -> () | Some edge -> - let* keys = pred key in - Lwt_list.iter_p (fun k -> edge key k) keys - else Lwt.return_unit + let keys = pred key in + List.iter (fun k -> edge key k) keys + else () in let visit_predecessors ~filter_history key level = - let+ keys = pred key in + let keys = pred key in (*if a commit is in [min] cut the history but still visit its nodes. *) List.iter @@ -150,13 +150,13 @@ struct keys in let visit key level = - if level >= depth then Lwt.return_unit - else if has_mark key then Lwt.return_unit + if level >= depth then () + else if has_mark key then () else - skip key >>= function - | true -> Lwt.return_unit + match skip key with + | true -> () | false -> - let+ () = + let () = [%log.debug "VISIT %a %d" Type.(pp X.t) key level]; mark key level; if rev then Stack.push (Treat key) todo; @@ -164,16 +164,16 @@ struct | `Commit _ -> visit_predecessors ~filter_history:(Set.mem key min) key level | _ -> - if Set.mem key min then Lwt.return_unit + if Set.mem key min then () else visit_predecessors ~filter_history:false key level in if not rev then Stack.push (Treat key) todo in let rec pop () = match Stack.pop todo with - | exception Stack.Empty -> Lwt.return_unit - | Treat key -> treat key >>= pop - | Visit (key, level) -> visit key level >>= pop + | exception Stack.Empty -> () + | Treat key -> pop (treat key) + | Visit (key, level) -> pop (visit key level) in pop () @@ -188,22 +188,23 @@ struct node key in let visit_predecessors key level = - let+ keys = pred key in + let keys = pred key in List.iter (fun k -> Queue.push (Visit (k, level + 1)) todo) keys in let visit key level = - if has_mark key then Lwt.return_unit + if has_mark key then () else ( [%log.debug "VISIT %a" Type.(pp X.t) key]; mark key level; - treat key >>= fun () -> visit_predecessors key level) + treat key; + visit_predecessors key level) in let rec pop () = match Queue.pop todo with - | exception Queue.Empty -> Lwt.return_unit + | exception Queue.Empty -> () | Treat _ -> Fmt.failwith "in bfs always treat the node as soon as its visited" - | Visit (key, level) -> visit key level >>= pop + | Visit (key, level) -> pop (visit key level) in pop () @@ -211,15 +212,12 @@ struct let g = G.create ~size:1024 () in List.iter (G.add_vertex g) max; let node key = - if not (G.mem_vertex g key) then G.add_vertex g key else (); - Lwt.return_unit + if not (G.mem_vertex g key) then G.add_vertex g key else () in - let edge node pred = - G.add_edge g pred node; - Lwt.return_unit - in - let skip _ = Lwt.return_false in - iter ~depth ~pred ~min ~max ~node ~edge ~skip ~rev:false () >|= fun () -> g + let edge node pred = G.add_edge g pred node in + let skip _ = false in + iter ~depth ~pred ~min ~max ~node ~edge ~skip ~rev:false (); + g let min g = G.fold_vertex diff --git a/src/irmin/object_graph_intf.ml b/src/irmin/object_graph_intf.ml index 063c3bbe0b..c07e15fec1 100644 --- a/src/irmin/object_graph_intf.ml +++ b/src/irmin/object_graph_intf.ml @@ -34,11 +34,11 @@ module type S = sig val closure : ?depth:int -> - pred:(vertex -> vertex list Lwt.t) -> + pred:(vertex -> vertex list) -> min:vertex list -> max:vertex list -> unit -> - t Lwt.t + t (** [closure depth pred min max ()] creates the transitive closure graph of [max] using the predecessor relation [pred]. The graph is bounded by the [min] nodes and by [depth]. @@ -48,15 +48,15 @@ module type S = sig val iter : ?cache_size:int -> ?depth:int -> - pred:(vertex -> vertex list Lwt.t) -> + pred:(vertex -> vertex list) -> min:vertex list -> max:vertex list -> - node:(vertex -> unit Lwt.t) -> - ?edge:(vertex -> vertex -> unit Lwt.t) -> - skip:(vertex -> bool Lwt.t) -> + node:(vertex -> unit) -> + ?edge:(vertex -> vertex -> unit) -> + skip:(vertex -> bool) -> rev:bool -> unit -> - unit Lwt.t + unit (** [iter depth min max node edge skip rev ()] iterates in topological order over the closure graph starting with the [max] nodes and bounded by the [min] nodes and by [depth]. @@ -76,11 +76,11 @@ module type S = sig val breadth_first_traversal : ?cache_size:int -> - pred:(vertex -> vertex list Lwt.t) -> + pred:(vertex -> vertex list) -> max:vertex list -> - node:(vertex -> unit Lwt.t) -> + node:(vertex -> unit) -> unit -> - unit Lwt.t + unit (** [breadth_first_traversal ?cache_size pred max node ()] traverses the closure graph in breadth-first order starting with the [max] nodes. It applies [node] on the nodes of the graph while traversing it. *) diff --git a/src/irmin/proof.ml b/src/irmin/proof.ml index f1cdd1b1bf..a25319cafa 100644 --- a/src/irmin/proof.ml +++ b/src/irmin/proof.ml @@ -150,7 +150,7 @@ struct let t = ref Empty in set_mode t Deserialise; let stop_deserialise () = set_mode t Consume in - let+ res = f t ~stop_deserialise in + let res = f t ~stop_deserialise in t := Empty; res @@ -158,7 +158,7 @@ struct let t = ref Empty in set_mode t Produce; let start_serialise () = set_mode t Serialise in - let+ res = f t ~start_serialise in + let res = f t ~start_serialise in t := Empty; res diff --git a/src/irmin/proof_intf.ml b/src/irmin/proof_intf.ml index f32892a1d8..86ce26ccfa 100644 --- a/src/irmin/proof_intf.ml +++ b/src/irmin/proof_intf.ml @@ -221,10 +221,10 @@ module type Env = sig val set_mode : t -> mode -> unit val with_produce : - (t -> start_serialise:(unit -> unit) -> 'a Lwt.t) -> 'a Lwt.t + (t -> start_serialise:(unit -> unit) -> 'a) -> 'a val with_consume : - (t -> stop_deserialise:(unit -> unit) -> 'a Lwt.t) -> 'a Lwt.t + (t -> stop_deserialise:(unit -> unit) -> 'a) -> 'a (** {2 Interactions With [Tree]} *) diff --git a/src/irmin/read_only_intf.ml b/src/irmin/read_only_intf.ml index 6191822305..1ac9d79441 100644 --- a/src/irmin/read_only_intf.ml +++ b/src/irmin/read_only_intf.ml @@ -33,10 +33,10 @@ module type S = sig type value (** The type for raw values. *) - val mem : [> read ] t -> key -> bool Lwt.t + val mem : [> read ] t -> key -> bool (** [mem t k] is true iff [k] is present in [t]. *) - val find : [> read ] t -> key -> value option Lwt.t + val find : [> read ] t -> key -> value option (** [find t k] is [Some v] if [k] is associated to [v] in [t] and [None] is [k] is not present in [t]. *) diff --git a/src/irmin/remote.ml b/src/irmin/remote.ml index b4d2247985..392997ac04 100644 --- a/src/irmin/remote.ml +++ b/src/irmin/remote.ml @@ -19,15 +19,12 @@ include Remote_intf module None (H : Type.S) (R : Type.S) = struct type t = unit - let v _ = Lwt.return_unit + let v _ = () type endpoint = unit type commit = H.t type branch = R.t - let fetch () ?depth:_ _ _br = - Lwt.return (Error (`Msg "fetch operation is not available")) - - let push () ?depth:_ _ _br = - Lwt.return (Error (`Msg "push operation is not available")) + let fetch () ?depth:_ _ _br = Error (`Msg "fetch operation is not available") + let push () ?depth:_ _ _br = Error (`Msg "push operation is not available") end diff --git a/src/irmin/remote_intf.ml b/src/irmin/remote_intf.ml index 4237c9a058..cd9dd6169a 100644 --- a/src/irmin/remote_intf.ml +++ b/src/irmin/remote_intf.ml @@ -36,7 +36,7 @@ module type S = sig ?depth:int -> endpoint -> branch -> - (commit option, [ `Msg of string ]) result Lwt.t + (commit option, [ `Msg of string ]) result (** [fetch t uri] fetches the contents of the remote store located at [uri] into the local store [t]. Return the head of the remote branch with the same name, which is now in the local store. [No_head] means no such branch @@ -47,7 +47,7 @@ module type S = sig ?depth:int -> endpoint -> branch -> - (unit, [ `Msg of string | `Detached_head ]) result Lwt.t + (unit, [ `Msg of string | `Detached_head ]) result (** [push t uri] pushes the contents of the local store [t] into the remote store located at [uri]. *) end @@ -63,7 +63,7 @@ module type Sigs = sig include S with type commit = H.t and type branch = R.t and type endpoint = unit - val v : 'a -> t Lwt.t + val v : 'a -> t (** Create a remote store handle. *) end end diff --git a/src/irmin/slice.ml b/src/irmin/slice.ml index 9f3e7580a8..ada639d4b6 100644 --- a/src/irmin/slice.ml +++ b/src/irmin/slice.ml @@ -35,24 +35,15 @@ struct } [@@deriving irmin] - let empty () = Lwt.return { contents = []; nodes = []; commits = [] } + let empty () = { contents = []; nodes = []; commits = [] } let add t = function - | `Contents c -> - t.contents <- c :: t.contents; - Lwt.return_unit - | `Node n -> - t.nodes <- n :: t.nodes; - Lwt.return_unit - | `Commit c -> - t.commits <- c :: t.commits; - Lwt.return_unit + | `Contents c -> t.contents <- c :: t.contents + | `Node n -> t.nodes <- n :: t.nodes + | `Commit c -> t.commits <- c :: t.commits let iter t f = - Lwt.join - [ - Lwt_list.iter_p (fun c -> f (`Contents c)) t.contents; - Lwt_list.iter_p (fun n -> f (`Node n)) t.nodes; - Lwt_list.iter_p (fun c -> f (`Commit c)) t.commits; - ] + List.iter (fun c -> f (`Contents c)) t.contents; + List.iter (fun n -> f (`Node n)) t.nodes; + List.iter (fun c -> f (`Commit c)) t.commits end diff --git a/src/irmin/slice_intf.ml b/src/irmin/slice_intf.ml index fc71483f35..e2ed375edc 100644 --- a/src/irmin/slice_intf.ml +++ b/src/irmin/slice_intf.ml @@ -33,13 +33,13 @@ module type S = sig [@@deriving irmin] (** The type for exported values. *) - val empty : unit -> t Lwt.t + val empty : unit -> t (** Create a new empty slice. *) - val add : t -> value -> unit Lwt.t + val add : t -> value -> unit (** [add t v] adds [v] to [t]. *) - val iter : t -> (value -> unit Lwt.t) -> unit Lwt.t + val iter : t -> (value -> unit) -> unit (** [iter t f] calls [f] on all values of [t]. *) end diff --git a/src/irmin/storage.ml b/src/irmin/storage.ml index 037d7ddb3b..01ebd85191 100644 --- a/src/irmin/storage.ml +++ b/src/irmin/storage.ml @@ -14,7 +14,6 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Import include Storage_intf module Read_only (M : Make) = @@ -48,14 +47,14 @@ functor let add t value = let key = H.hash value in - let+ () = S.set t key value in + let () = S.set t key value in key let equal_hash = Type.(equal H.t |> unstage) let pp_hash = Type.(pp H.t) let unsafe_add t k v = - let+ hash' = add t v in + let hash' = add t v in if equal_hash k hash' then () else Fmt.failwith @@ -94,19 +93,19 @@ functor let lock = L.v () let v config = - let* t = S.v config in - Lwt.return { t; w = watches; l = lock } + let t = S.v config in + { t; w = watches; l = lock } let find { t; _ } = S.find t let mem { t; _ } = S.mem t module Internal = struct let set t w key value = - let* () = S.set t key value in + let () = S.set t key value in W.notify w key (Some value) let remove t w key = - let* () = S.remove t key in + let () = S.remove t key in W.notify w key None end @@ -122,25 +121,25 @@ functor let value_equal = Type.(unstage (equal (option Value.t))) in fun { t; l; w } key ~test ~set:set_value -> L.with_lock l key @@ fun () -> - let* v = S.find t key in + let v = S.find t key in if value_equal v test then - let* () = + let () = match set_value with | Some set_value -> Internal.set t w key set_value | None -> Internal.remove t w key in - Lwt.return_true - else Lwt.return_false + true + else false let watch_key { w; _ } key = W.watch_key w key let watch { w; _ } = W.watch w let unwatch { w; _ } = W.unwatch w let clear { t; w; _ } = - let* () = W.clear w in + let () = W.clear w in S.clear t let close { t; w; _ } = - let* () = W.clear w in + let () = W.clear w in S.close t end diff --git a/src/irmin/storage_intf.ml b/src/irmin/storage_intf.ml index 34486228e8..8dd475ee9c 100644 --- a/src/irmin/storage_intf.ml +++ b/src/irmin/storage_intf.ml @@ -19,33 +19,33 @@ module type S = sig type key type value - val v : Conf.t -> t Lwt.t + val v : Conf.t -> t (** [v config] initialises a storage layer, with the configuration [config]. *) - val mem : t -> key -> bool Lwt.t + val mem : t -> key -> bool (** [mem t k] is true iff [k] is present in [t]. *) - val find : t -> key -> value option Lwt.t + val find : t -> key -> value option (** [find t k] is [Some v] if [k] is associated to [v] in [t] and [None] is [k] is not present in [t]. *) - val keys : t -> key list Lwt.t + val keys : t -> key list (** [keys t] it the list of keys in [t]. *) - val set : t -> key -> value -> unit Lwt.t + val set : t -> key -> value -> unit (** [set t k v] sets the contents of [k] to [v] in [t]. *) - val remove : t -> key -> unit Lwt.t + val remove : t -> key -> unit (** [remove t k] removes the key [k] in [t]. *) - val batch : t -> (t -> 'a Lwt.t) -> 'a Lwt.t + val batch : t -> (t -> 'a) -> 'a (** [batch t f] applies the operations in [f] in a batch. The exact guarantees depend on the implementation. *) - val clear : t -> unit Lwt.t + val clear : t -> unit (** [clear t] clears the storage. This operation is expected to be slow. *) - val close : t -> unit Lwt.t + val close : t -> unit (** [close t] frees up all the resources associated with [t]. *) end diff --git a/src/irmin/store.ml b/src/irmin/store.ml index b73edf07bd..b47f34b7d0 100644 --- a/src/irmin/store.ml +++ b/src/irmin/store.ml @@ -57,8 +57,8 @@ module Make (B : Backend.S) = struct let of_hash r h = let store = B.Repo.contents_t r in - B.Contents.index store h >>= function - | None -> Lwt.return_none + match B.Contents.index store h with + | None -> None | Some k -> B.Contents.find store k let hash c = H.hash c @@ -69,15 +69,15 @@ module Make (B : Backend.S) = struct let find_key r t = match key t with - | Some k -> Lwt.return (Some k) + | Some k -> Some k | None -> ( match hash t with | `Node h -> ( - B.Node.index (B.Repo.node_t r) h >|= function + match B.Node.index (B.Repo.node_t r) h with | None -> None | Some k -> Some (`Node k)) | `Contents (h, m) -> ( - B.Contents.index (B.Repo.contents_t r) h >|= function + match B.Contents.index (B.Repo.contents_t r) h with | None -> None | Some k -> Some (`Contents (k, m)))) @@ -85,12 +85,12 @@ module Make (B : Backend.S) = struct let of_hash r = function | `Node h -> ( - B.Node.index (B.Repo.node_t r) h >>= function - | None -> Lwt.return_none + match B.Node.index (B.Repo.node_t r) h with + | None -> None | Some k -> of_key r (`Node k)) | `Contents (h, m) -> ( - B.Contents.index (B.Repo.contents_t r) h >>= function - | None -> Lwt.return_none + match B.Contents.index (B.Repo.contents_t r) h with + | None -> None | Some k -> of_key r (`Contents (k, m))) let shallow r h = import_no_check r h @@ -152,11 +152,11 @@ module Make (B : Backend.S) = struct let save_tree ?(clear = true) r x y (tr : Tree.t) = match Tree.destruct tr with | `Contents (c, _) -> - let* c = Tree.Contents.force_exn c in - let+ k = save_contents x c in + let c = Tree.Contents.force_exn c in + let k = save_contents x c in `Contents k | `Node n -> - let+ k = Tree.export ~clear r x y n in + let k = Tree.export ~clear r x y n in `Node k module Contents_keys = Set.Make (struct @@ -175,13 +175,13 @@ module Make (B : Backend.S) = struct let v ?(clear = true) r ~info ~parents tree = B.Repo.batch r @@ fun contents_t node_t commit_t -> - let* node = + let node = match Tree.destruct tree with | `Node t -> Tree.export ~clear r contents_t node_t t - | `Contents _ -> Lwt.fail_invalid_arg "cannot add contents at the root" + | `Contents _ -> invalid_arg "cannot add contents at the root" in let v = B.Commit.Val.v ~info ~node ~parents in - let+ key = B.Commit.add commit_t v in + let key = B.Commit.add commit_t v in { r; key; v } let node t = B.Commit.Val.node t.v @@ -196,13 +196,13 @@ module Make (B : Backend.S) = struct let pp ppf commit = Type.pp (t commit.r) ppf commit let of_key r key = - B.Commit.find (B.Repo.commit_t r) key >|= function + match B.Commit.find (B.Repo.commit_t r) key with | None -> None | Some v -> Some { r; key; v } let of_hash r hash = - B.Commit.index (B.Repo.commit_t r) hash >>= function - | None -> Lwt.return_none + match B.Commit.index (B.Repo.commit_t r) hash with + | None -> None | Some key -> of_key r key module H = Typed (B.Commit.Val) @@ -233,7 +233,7 @@ module Make (B : Backend.S) = struct (Branch_store.Key) type slice = B.Slice.t [@@deriving irmin] - type watch = unit -> unit Lwt.t + type watch = unit -> unit let unwatch w = w () @@ -251,15 +251,13 @@ module Make (B : Backend.S) = struct let heads repo = let t = branch_t repo in - let* bs = Branch_store.list t in - Lwt_list.fold_left_s + let bs = Branch_store.list t in + List.fold_left (fun acc r -> - Branch_store.find t r >>= function - | None -> Lwt.return acc + match Branch_store.find t r with + | None -> acc | Some k -> ( - Commit.of_key repo k >|= function - | None -> acc - | Some h -> h :: acc)) + match Commit.of_key repo k with None -> acc | Some h -> h :: acc)) [] bs let export ?(full = true) ?depth ?(min = []) ?(max = `Head) t = @@ -270,114 +268,91 @@ module Make (B : Backend.S) = struct (match max with | `Head -> "heads" | `Max m -> string_of_int (List.length m))]; - let* max = match max with `Head -> heads t | `Max m -> Lwt.return m in - let* slice = B.Slice.empty () in + let max = match max with `Head -> heads t | `Max m -> m in + let slice = B.Slice.empty () in let max = List.map (fun x -> `Commit x.key) max in let min = List.map (fun x -> `Commit x.key) min in let pred = function | `Commit k -> - let+ parents = Commits.parents (commit_t t) k in + let parents = Commits.parents (commit_t t) k in List.map (fun x -> `Commit x) parents - | _ -> Lwt.return_nil + | _ -> [] in - let* g = KGraph.closure ?depth ~pred ~min ~max () in + let g = KGraph.closure ?depth ~pred ~min ~max () in let keys = List.fold_left (fun acc -> function `Commit c -> c :: acc | _ -> acc) [] (KGraph.vertex g) in let root_nodes = ref [] in - let* () = - Lwt_list.iter_p - (fun k -> - B.Commit.find (commit_t t) k >>= function - | None -> Lwt.return_unit - | Some c -> - root_nodes := B.Commit.Val.node c :: !root_nodes; - B.Slice.add slice (`Commit (Commit_key.to_hash k, c))) - keys - in - if not full then Lwt.return slice + List.iter + (fun k -> + match B.Commit.find (commit_t t) k with + | None -> () + | Some c -> + root_nodes := B.Commit.Val.node c :: !root_nodes; + B.Slice.add slice (`Commit (Commit_key.to_hash k, c))) + keys; + if not full then slice else (* XXX: we can compute a [min] if needed *) - let* nodes = Graph.closure (node_t t) ~min:[] ~max:!root_nodes in + let nodes = Graph.closure (node_t t) ~min:[] ~max:!root_nodes in let contents = ref Contents_keys.empty in - let* () = - Lwt_list.iter_p - (fun k -> - B.Node.find (node_t t) k >>= function - | None -> Lwt.return_unit - | Some v -> - List.iter - (function - | _, `Contents (c, _) -> - contents := Contents_keys.add c !contents - | _ -> ()) - (B.Node.Val.list v); - B.Slice.add slice (`Node (Node_key.to_hash k, v))) - nodes - in - let+ () = - Lwt_list.iter_p - (fun k -> - B.Contents.find (contents_t t) k >>= function - | None -> Lwt.return_unit - | Some m -> - B.Slice.add slice (`Contents (Contents_key.to_hash k, m))) - (Contents_keys.elements !contents) - in + List.iter + (fun k -> + match B.Node.find (node_t t) k with + | None -> () + | Some v -> + List.iter + (function + | _, `Contents (c, _) -> + contents := Contents_keys.add c !contents + | _ -> ()) + (B.Node.Val.list v); + B.Slice.add slice (`Node (Node_key.to_hash k, v))) + nodes; + List.iter + (fun k -> + match B.Contents.find (contents_t t) k with + | None -> () + | Some m -> + B.Slice.add slice (`Contents (Contents_key.to_hash k, m))) + (Contents_keys.elements !contents); slice exception Import_error of string - let import_error fmt = Fmt.kstr (fun x -> Lwt.fail (Import_error x)) fmt + let import_error fmt = Fmt.kstr (fun x -> raise (Import_error x)) fmt let import t s = let aux name key_to_hash add (h, v) = - let* k' = add v in + let k' = add v in let h' = key_to_hash k' in if not (equal_hash h h') then import_error "%s import error: expected %a, got %a" name pp_hash h pp_hash h' - else Lwt.return_unit + else () in let contents = ref [] in let nodes = ref [] in let commits = ref [] in - let* () = - B.Slice.iter s (function - | `Contents c -> - contents := c :: !contents; - Lwt.return_unit - | `Node n -> - nodes := n :: !nodes; - Lwt.return_unit - | `Commit c -> - commits := c :: !commits; - Lwt.return_unit) - in + B.Slice.iter s (function + | `Contents c -> contents := c :: !contents + | `Node n -> nodes := n :: !nodes + | `Commit c -> commits := c :: !commits); B.Repo.batch t @@ fun contents_t node_t commit_t -> - Lwt.catch - (fun () -> - let* () = - Lwt_list.iter_p - (aux "Contents" B.Contents.Key.to_hash - (B.Contents.add contents_t)) - !contents - in - Lwt_list.iter_p - (aux "Node" B.Node.Key.to_hash (B.Node.add node_t)) - !nodes - >>= fun () -> - let+ () = - Lwt_list.iter_p - (aux "Commit" B.Commit.Key.to_hash (B.Commit.add commit_t)) - !commits - in - Ok ()) - (function - | Import_error e -> Lwt.return (Error (`Msg e)) - | e -> Fmt.kstr Lwt.fail_invalid_arg "impot error: %a" Fmt.exn e) + try + List.iter + (aux "Contents" B.Contents.Key.to_hash (B.Contents.add contents_t)) + !contents; + List.iter (aux "Node" B.Node.Key.to_hash (B.Node.add node_t)) !nodes; + List.iter + (aux "Commit" B.Commit.Key.to_hash (B.Commit.add commit_t)) + !commits; + Ok () + with + | Import_error e -> Error (`Msg e) + | e -> Fmt.kstr invalid_arg "impot error: %a" Fmt.exn e type elt = [ `Commit of commit_key @@ -386,12 +361,11 @@ module Make (B : Backend.S) = struct | `Branch of B.Branch.Key.t ] [@@deriving irmin] - let ignore_lwt _ = Lwt.return_unit - let return_false _ = Lwt.return false - let default_pred_contents _ _ = Lwt.return [] + let return_false _ = false + let default_pred_contents _ _ = [] let default_pred_node t k = - B.Node.find (node_t t) k >|= function + match B.Node.find (node_t t) k with | None -> [] | Some v -> List.rev_map @@ -400,7 +374,7 @@ module Make (B : Backend.S) = struct (B.Node.Val.list v) let default_pred_commit t c = - B.Commit.find (commit_t t) c >|= function + match B.Commit.find (commit_t t) c with | None -> [%log.debug "%a: not found" pp_commit_key c]; [] @@ -410,17 +384,16 @@ module Make (B : Backend.S) = struct [ `Node node ] @ List.map (fun k -> `Commit k) parents let default_pred_branch t b = - B.Branch.find (branch_t t) b >|= function + match B.Branch.find (branch_t t) b with | None -> [%log.debug "%a: not found" pp_branch b]; [] | Some b -> [ `Commit b ] - let iter ?cache_size ~min ~max ?edge ?(branch = ignore_lwt) - ?(commit = ignore_lwt) ?(node = ignore_lwt) ?(contents = ignore_lwt) - ?(skip_branch = return_false) ?(skip_commit = return_false) - ?(skip_node = return_false) ?(skip_contents = return_false) - ?(pred_branch = default_pred_branch) + let iter ?cache_size ~min ~max ?edge ?(branch = ignore) ?(commit = ignore) + ?(node = ignore) ?(contents = ignore) ?(skip_branch = return_false) + ?(skip_commit = return_false) ?(skip_node = return_false) + ?(skip_contents = return_false) ?(pred_branch = default_pred_branch) ?(pred_commit = default_pred_commit) ?(pred_node = default_pred_node) ?(pred_contents = default_pred_contents) ?(rev = true) t = let node = function @@ -443,8 +416,8 @@ module Make (B : Backend.S) = struct in KGraph.iter ?cache_size ~pred ~min ~max ~node ?edge ~skip ~rev () - let breadth_first_traversal ?cache_size ~max ?(branch = ignore_lwt) - ?(commit = ignore_lwt) ?(node = ignore_lwt) ?(contents = ignore_lwt) + let breadth_first_traversal ?cache_size ~max ?(branch = ignore) + ?(commit = ignore) ?(node = ignore) ?(contents = ignore) ?(pred_branch = default_pred_branch) ?(pred_commit = default_pred_commit) ?(pred_node = default_pred_node) ?(pred_contents = default_pred_contents) t = @@ -468,7 +441,7 @@ module Make (B : Backend.S) = struct head_ref : head_ref; mutable tree : (commit * tree) option; (* cache for the store tree *) - lock : Lwt_mutex.t; + lock : Eio.Mutex.t; } let repo t = t.repo @@ -486,16 +459,14 @@ module Make (B : Backend.S) = struct | `Head h -> ( match !h with None -> `Empty | Some h -> `Head h) let branch t = - match head_ref t with - | `Branch t -> Lwt.return_some t - | `Empty | `Head _ -> Lwt.return_none + match head_ref t with `Branch t -> Some t | `Empty | `Head _ -> None - let err_no_head s = Fmt.kstr Lwt.fail_invalid_arg "Irmin.%s: no head" s + let err_no_head s = Fmt.kstr invalid_arg "Irmin.%s: no head" s let retry_merge name fn = let rec aux i = - fn () >>= function - | Error _ as c -> Lwt.return c + match fn () with + | Error _ as c -> c | Ok true -> Merge.ok () | Ok false -> [%log.debug "Irmin.%s: conflict, retrying (%d)." name i]; @@ -504,12 +475,12 @@ module Make (B : Backend.S) = struct aux 1 let of_ref repo head_ref = - let lock = Lwt_mutex.create () in - Lwt.return { lock; head_ref; repo; tree = None } + let lock = Eio.Mutex.create () in + { lock; head_ref; repo; tree = None } let err_invalid_branch t = let err = Fmt.str "%a is not a valid branch name." pp_branch t in - Lwt.fail (Invalid_argument err) + raise (Invalid_argument err) let of_branch repo key = if Branch_store.Key.is_valid key then of_ref repo (`Branch key) @@ -521,8 +492,7 @@ module Make (B : Backend.S) = struct let of_commit c = of_ref c.r (`Head (ref (Some c))) let skip_key key = - [%log.debug "[watch-key] key %a has not changed" pp_path key]; - Lwt.return_unit + [%log.debug "[watch-key] key %a has not changed" pp_path key] let changed_key key old_t new_t = [%log.debug @@ -534,7 +504,8 @@ module Make (B : Backend.S) = struct new_h] let with_tree ~key x f = - x >>= function + match x with + (* Hmmmm *) | None -> skip_key key | Some x -> changed_key key None None; @@ -551,8 +522,8 @@ module Make (B : Backend.S) = struct fn @@ `Added (x, v) | `Updated (x, y) -> ( assert (not (Commit.equal x y)); - let* vx = tree x in - let* vy = tree y in + let vx = tree x in + let vy = tree y in match (vx, vy) with | None, None -> skip_key key | None, Some vy -> @@ -570,19 +541,18 @@ module Make (B : Backend.S) = struct let head t = let h = match head_ref t with - | `Head key -> Lwt.return_some key - | `Empty -> Lwt.return_none + | `Head key -> Some key + | `Empty -> None | `Branch name -> ( - Branch_store.find (branch_store t) name >>= function - | None -> Lwt.return_none + match Branch_store.find (branch_store t) name with + | None -> None | Some k -> Commit.of_key t.repo k) in - let+ h = h in [%log.debug "Head.find -> %a" Fmt.(option Commit.pp_key) h]; h let tree_and_head t = - head t >|= function + match head t with | None -> None | Some h -> ( match t.tree with @@ -596,30 +566,26 @@ module Make (B : Backend.S) = struct Some (h, tree)) let tree t = - tree_and_head t >|= function + match tree_and_head t with | None -> Tree.empty () | Some (_, tree) -> (tree :> tree) let lift_head_diff repo fn = function | `Removed x -> ( - Commit.of_key repo x >>= function - | None -> Lwt.return_unit - | Some x -> fn (`Removed x)) + match Commit.of_key repo x with None -> () | Some x -> fn (`Removed x)) | `Updated (x, y) -> ( - let* x = Commit.of_key repo x in - let* y = Commit.of_key repo y in + let x = Commit.of_key repo x in + let y = Commit.of_key repo y in match (x, y) with - | None, None -> Lwt.return_unit + | None, None -> () | Some x, None -> fn (`Removed x) | None, Some y -> fn (`Added y) | Some x, Some y -> fn (`Updated (x, y))) | `Added x -> ( - Commit.of_key repo x >>= function - | None -> Lwt.return_unit - | Some x -> fn (`Added x)) + match Commit.of_key repo x with None -> () | Some x -> fn (`Added x)) let watch t ?init fn = - branch t >>= function + match branch t with | None -> failwith "watch a detached head: TODO" | Some name0 -> let init = @@ -627,10 +593,10 @@ module Make (B : Backend.S) = struct | None -> None | Some head0 -> Some [ (name0, head0.key) ] in - let+ key = + let key = Branch_store.watch (branch_store t) ?init (fun name head -> if equal_branch name0 name then lift_head_diff t.repo fn head - else Lwt.return_unit) + else ()) in fun () -> Branch_store.unwatch (branch_store t) key @@ -642,15 +608,11 @@ module Make (B : Backend.S) = struct module Head = struct let list = Repo.heads let find = head - - let get t = - find t >>= function None -> err_no_head "head" | Some k -> Lwt.return k + let get t = match find t with None -> err_no_head "head" | Some k -> k let set t c = match t.head_ref with - | `Head h -> - h := Some c; - Lwt.return_unit + | `Head h -> h := Some c | `Branch name -> Branch_store.set (branch_store t) name c.key let test_and_set_unsafe t ~test ~set = @@ -659,37 +621,38 @@ module Make (B : Backend.S) = struct (* [head] is protected by [t.lock]. *) if Commit.equal_opt !head test then ( head := set; - Lwt.return_true) - else Lwt.return_false + true) + else false | `Branch name -> let h = function None -> None | Some c -> Some c.key in Branch_store.test_and_set (branch_store t) name ~test:(h test) ~set:(h set) let test_and_set t ~test ~set = - Lwt_mutex.with_lock t.lock (fun () -> test_and_set_unsafe t ~test ~set) + Eio.Mutex.use_rw ~protect:true t.lock (fun () -> test_and_set_unsafe t ~test ~set) let fast_forward t ?max_depth ?n new_head = let return x = if x then Ok () else Error (`Rejected :> ff_error) in - find t >>= function - | None -> test_and_set t ~test:None ~set:(Some new_head) >|= return + match find t with + | None -> test_and_set t ~test:None ~set:(Some new_head) |> return | Some old_head -> ( [%log.debug "fast-forward-head old=%a new=%a" Commit.pp_hash old_head Commit.pp_hash new_head]; if Commit.equal new_head old_head then (* we only update if there is a change *) - Lwt.return (Error `No_change) + Error `No_change else - Commits.lcas (commit_store t) ?max_depth ?n new_head.key - old_head.key - >>= function + match + Commits.lcas (commit_store t) ?max_depth ?n new_head.key + old_head.key + with | Ok [ x ] when equal_commit_key x old_head.key -> (* we only update if new_head > old_head *) test_and_set t ~test:(Some old_head) ~set:(Some new_head) - >|= return - | Ok _ -> Lwt.return (Error `Rejected) - | Error e -> Lwt.return (Error (e :> ff_error))) + |> return + | Ok _ -> Error `Rejected + | Error e -> Error (e :> ff_error)) (* Merge two commits: - Search for common ancestors @@ -703,15 +666,15 @@ module Make (B : Backend.S) = struct let merge ~into:t ~info ?max_depth ?n c1 = [%log.debug "merge_head"]; let aux () = - let* head = head t in + let head = head t in match head with - | None -> test_and_set_unsafe t ~test:head ~set:(Some c1) >>= Merge.ok + | None -> test_and_set_unsafe t ~test:head ~set:(Some c1) |> Merge.ok | Some c2 -> three_way_merge t ~info ?max_depth ?n c1 c2 >>=* fun c3 -> - let* c3 = Commit.of_key t.repo c3 in - test_and_set_unsafe t ~test:head ~set:c3 >>= Merge.ok + let c3 = Commit.of_key t.repo c3 in + test_and_set_unsafe t ~test:head ~set:c3 |> Merge.ok in - Lwt_mutex.with_lock t.lock (fun () -> retry_merge "merge_head" aux) + Eio.Mutex.use_rw ~protect:true t.lock (fun () -> retry_merge "merge_head" aux) end (* Retry an operation until the optimistic lock is happy. Ensure @@ -719,12 +682,11 @@ module Make (B : Backend.S) = struct let retry ~retries fn = let done_once = ref false in let rec aux i = - if !done_once && i > retries then - Lwt.return (Error (`Too_many_retries retries)) + if !done_once && i > retries then Error (`Too_many_retries retries) else - fn () >>= function - | Ok (c, true) -> Lwt.return (Ok c) - | Error e -> Lwt.return (Error e) + match fn () with + | Ok (c, true) -> Ok c + | Error e -> Error e | Ok (_, false) -> done_once := true; aux (i + 1) @@ -738,20 +700,20 @@ module Make (B : Backend.S) = struct let add_commit t old_head ((c, _) as tree) = match t.head_ref with | `Head head -> - Lwt_mutex.with_lock t.lock (fun () -> - if not (Commit.equal_opt old_head !head) then Lwt.return_false + Eio.Mutex.use_rw ~protect:true t.lock (fun () -> + if not (Commit.equal_opt old_head !head) then false else ( (* [head] is protected by [t.lock] *) head := Some c; t.tree <- Some tree; - Lwt.return_true)) + true)) | `Branch name -> (* concurrent handlers and/or process can modify the branch. Need to check that we are still working on the same head. *) let test = match old_head with None -> None | Some c -> Some c.key in let set = Some c.key in - let+ r = Branch_store.test_and_set (branch_store t) name ~test ~set in + let r = Branch_store.test_and_set (branch_store t) name ~test ~set in if r then t.tree <- Some tree; r @@ -766,7 +728,7 @@ module Make (B : Backend.S) = struct Fmt.(Dump.option pp_tree) t - let write_error e : ('a, write_error) result Lwt.t = Lwt.return (Error e) + let write_error e : ('a, write_error) result = Error e let err_test v = write_error (`Test_was v) type snapshot = { @@ -778,13 +740,11 @@ module Make (B : Backend.S) = struct } let snapshot t key = - tree_and_head t >>= function - | None -> - Lwt.return - { head = None; root = Tree.empty (); tree = None; parents = [] } + match tree_and_head t with + | None -> { head = None; root = Tree.empty (); tree = None; parents = [] } | Some (c, root) -> let root = (root :> tree) in - let+ tree = Tree.find_tree root key in + let tree = Tree.find_tree root key in { head = Some c; root; tree; parents = [ c ] } let same_tree x y = @@ -797,37 +757,37 @@ module Make (B : Backend.S) = struct in the process. *) let update ?(clear = true) ?(allow_empty = false) ~info ?parents t key merge_tree f = - let* s = snapshot t key in + let s = snapshot t key in (* this might take a very long time *) - let* new_tree = f s.tree in + let new_tree = f s.tree in (* if no change and [allow_empty = true] then, do nothing *) if same_tree s.tree new_tree && (not allow_empty) && s.head <> None then - Lwt.return (Ok (None, true)) + Ok (None, true) else - merge_tree s.root key ~current_tree:s.tree ~new_tree >>= function - | Error e -> Lwt.return (Error e) + match merge_tree s.root key ~current_tree:s.tree ~new_tree with + | Error e -> Error e | Ok root -> let info = info () in let parents = match parents with None -> s.parents | Some p -> p in let parents = List.map Commit.key parents in - let* c = Commit.v ~clear (repo t) ~info ~parents root in - let* r = add_commit t s.head (c, root_tree (Tree.destruct root)) in - Lwt.return (Ok (Some c, r)) + let c = Commit.v ~clear (repo t) ~info ~parents root in + let r = add_commit t s.head (c, root_tree (Tree.destruct root)) in + Ok (Some c, r) let ok x = Ok x let fail name = function - | Ok x -> Lwt.return x - | Error e -> Fmt.kstr Lwt.fail_with "%s: %a" name pp_write_error e + | Ok x -> x + | Error e -> Fmt.kstr invalid_arg "%s: %a" name pp_write_error e let set_tree_once root key ~current_tree:_ ~new_tree = match new_tree with - | None -> Tree.remove root key >|= ok - | Some tree -> Tree.add_tree root key tree >|= ok + | None -> Tree.remove root key |> ok + | Some tree -> Tree.add_tree root key tree |> ok let ignore_commit - (c : (commit option, [> `Too_many_retries of int ]) result Lwt.t) = - Lwt_result.map (fun _ -> ()) c + (_c : (commit option, [> `Too_many_retries of int ]) result) = + Ok () let set_tree ?clear ?(retries = 13) ?allow_empty ?parents ~info t k v = [%log.debug "set %a" pp_path k]; @@ -835,11 +795,10 @@ module Make (B : Backend.S) = struct @@ retry ~retries @@ fun () -> update t k ?clear ?allow_empty ?parents ~info set_tree_once @@ fun _tree -> - Lwt.return_some v + Some v let set_tree_exn ?clear ?retries ?allow_empty ?parents ~info t k v = - set_tree ?clear ?retries ?allow_empty ?parents ~info t k v - >>= fail "set_exn" + set_tree ?clear ?retries ?allow_empty ?parents ~info t k v |> fail "set_exn" let remove ?clear ?(retries = 13) ?allow_empty ?parents ~info t k = [%log.debug "debug %a" pp_path k]; @@ -847,17 +806,17 @@ module Make (B : Backend.S) = struct @@ retry ~retries @@ fun () -> update t k ?clear ?allow_empty ?parents ~info set_tree_once @@ fun _tree -> - Lwt.return_none + None let remove_exn ?clear ?retries ?allow_empty ?parents ~info t k = - remove ?clear ?retries ?allow_empty ?parents ~info t k >>= fail "remove_exn" + remove ?clear ?retries ?allow_empty ?parents ~info t k |> fail "remove_exn" let set ?clear ?retries ?allow_empty ?parents ~info t k v = let v = Tree.of_contents v in set_tree t k ?clear ?retries ?allow_empty ?parents ~info v let set_exn ?clear ?retries ?allow_empty ?parents ~info t k v = - set t k ?clear ?retries ?allow_empty ?parents ~info v >>= fail "set_exn" + set t k ?clear ?retries ?allow_empty ?parents ~info v |> fail "set_exn" let test_and_set_tree_once ~test root key ~current_tree ~new_tree = match (test, current_tree) with @@ -872,13 +831,12 @@ module Make (B : Backend.S) = struct [%log.debug "test-and-set %a" pp_path k]; retry ~retries @@ fun () -> update t k ?clear ?allow_empty ?parents ~info (test_and_set_tree_once ~test) - @@ fun _tree -> Lwt.return set + @@ fun _tree -> set - let test_set_and_get_tree_exn ?clear ?retries ?allow_empty ?parents ~info t k - ~test ~set = - test_set_and_get_tree ?clear ?retries ?allow_empty ?parents ~info t k ~test - ~set - >>= fail "test_set_and_get_tree_exn" + let test_set_and_get_tree_exn ?clear ?retries ?allow_empty ?parents ~info t k ~test + ~set = + test_set_and_get_tree ?clear ?retries ?allow_empty ?parents ~info t k ~test ~set + |> fail "test_set_and_get_tree_exn" let test_set_and_get ?clear ?retries ?allow_empty ?parents ~info t k ~test ~set = @@ -887,10 +845,9 @@ module Make (B : Backend.S) = struct test_set_and_get_tree ?clear ?retries ?allow_empty ?parents ~info t k ~test ~set - let test_set_and_get_exn ?clear ?retries ?allow_empty ?parents ~info t k ~test - ~set = + let test_set_and_get_exn ?clear ?retries ?allow_empty ?parents ~info t k ~test ~set = test_set_and_get ?clear ?retries ?allow_empty ?parents ~info t k ~test ~set - >>= fail "test_set_and_get_exn" + |> fail "test_set_and_get_exn" let test_and_set_tree ?clear ?(retries = 13) ?allow_empty ?parents ~info t k ~test ~set = @@ -899,10 +856,10 @@ module Make (B : Backend.S) = struct @@ test_set_and_get_tree ~retries ?clear ?allow_empty ?parents ~info t k ~test ~set - let test_and_set_tree_exn ?clear ?retries ?allow_empty ?parents ~info t k - ~test ~set = + let test_and_set_tree_exn ?clear ?retries ?allow_empty ?parents ~info t k ~test ~set + = test_and_set_tree ?clear ?retries ?allow_empty ?parents ~info t k ~test ~set - >>= fail "test_and_set_tree_exn" + |> fail "test_and_set_tree_exn" let test_and_set ?clear ?retries ?allow_empty ?parents ~info t k ~test ~set = ignore_commit @@ -912,11 +869,11 @@ module Make (B : Backend.S) = struct let test_and_set_exn ?clear ?retries ?allow_empty ?parents ~info t k ~test ~set = test_and_set ?clear ?retries ?allow_empty ?parents ~info t k ~test ~set - >>= fail "test_and_set_exn" + |> fail "test_and_set_exn" let merge_once ~old root key ~current_tree ~new_tree = let old = Merge.promise old in - Merge.f (Merge.option Tree.merge) ~old current_tree new_tree >>= function + match Merge.f (Merge.option Tree.merge) ~old current_tree new_tree with | Ok tr -> set_tree_once root key ~new_tree:tr ~current_tree | Error e -> write_error (e :> write_error) @@ -931,7 +888,7 @@ module Make (B : Backend.S) = struct let merge_tree_exn ?clear ?retries ?allow_empty ?parents ~info ~old t k tree = merge_tree ?clear ?retries ?allow_empty ?parents ~info ~old t k tree - >>= fail "merge_tree_exn" + |> fail "merge_tree_exn" let merge ?clear ?retries ?allow_empty ?parents ~info ~old t k v = let old = Option.map Tree.of_contents old in @@ -940,18 +897,18 @@ module Make (B : Backend.S) = struct let merge_exn ?clear ?retries ?allow_empty ?parents ~info ~old t k v = merge ?clear ?retries ?allow_empty ?parents ~info ~old t k v - >>= fail "merge_exn" + |> fail "merge_exn" - let mem t k = tree t >>= fun tree -> Tree.mem tree k - let mem_tree t k = tree t >>= fun tree -> Tree.mem_tree tree k - let find_all t k = tree t >>= fun tree -> Tree.find_all tree k - let find t k = tree t >>= fun tree -> Tree.find tree k - let get t k = tree t >>= fun tree -> Tree.get tree k - let find_tree t k = tree t >>= fun tree -> Tree.find_tree tree k - let get_tree t k = tree t >>= fun tree -> Tree.get_tree tree k + let mem t k = tree t |> fun tree -> Tree.mem tree k + let mem_tree t k = tree t |> fun tree -> Tree.mem_tree tree k + let find_all t k = tree t |> fun tree -> Tree.find_all tree k + let find t k = tree t |> fun tree -> Tree.find tree k + let get t k = tree t |> fun tree -> Tree.get tree k + let find_tree t k = tree t |> fun tree -> Tree.find_tree tree k + let get_tree t k = tree t |> fun tree -> Tree.get_tree tree k let key t k = - find_tree t k >|= function + match find_tree t k with | None -> None | Some tree -> ( match Tree.key tree with @@ -960,13 +917,11 @@ module Make (B : Backend.S) = struct | None -> None) let hash t k = - find_tree t k >|= function - | None -> None - | Some tree -> Some (Tree.hash tree) + match find_tree t k with None -> None | Some tree -> Some (Tree.hash tree) - let get_all t k = tree t >>= fun tree -> Tree.get_all tree k - let list t k = tree t >>= fun tree -> Tree.list tree k - let kind t k = tree t >>= fun tree -> Tree.kind tree k + let get_all t k = tree t |> fun tree -> Tree.get_all tree k + let list t k = tree t |> fun tree -> Tree.list tree k + let kind t k = tree t |> fun tree -> Tree.kind tree k let with_tree ?clear ?(retries = 13) ?allow_empty ?parents ?(strategy = `Test_and_set) ~info t key f = @@ -975,90 +930,91 @@ module Make (B : Backend.S) = struct [%log.debug "with_tree %a (%d/%d)" pp_path key n retries]; if !done_once && n > retries then write_error (`Too_many_retries retries) else - let* new_tree = f old_tree in + let new_tree = f old_tree in match (strategy, new_tree) with | `Set, Some tree -> set_tree ?clear t key ~retries ?allow_empty ?parents tree ~info | `Set, None -> remove ?clear t key ~retries ?allow_empty ~info ?parents | `Test_and_set, _ -> ( - test_and_set_tree ?clear t key ~retries ?allow_empty ?parents ~info - ~test:old_tree ~set:new_tree - >>= function + match + test_and_set_tree ?clear t key ~retries ?allow_empty ?parents ~info + ~test:old_tree ~set:new_tree + with | Error (`Test_was tr) when retries > 0 && n <= retries -> done_once := true; aux (n + 1) tr - | e -> Lwt.return e) + | e -> e) | `Merge, _ -> ( - merge_tree ?clear ~old:old_tree ~retries ?allow_empty ?parents ~info - t key new_tree - >>= function - | Ok _ as x -> Lwt.return x + match + merge_tree ?clear ~old:old_tree ~retries ?allow_empty ?parents ~info t + key new_tree + with + | Ok _ as x -> x | Error (`Conflict _) when retries > 0 && n <= retries -> done_once := true; (* use the store's current tree as the new 'old store' *) - let* old_tree = - tree_and_head t >>= function - | None -> Lwt.return_none + let old_tree = + match tree_and_head t with + | None -> None | Some (_, tr) -> Tree.find_tree (tr :> tree) key in aux (n + 1) old_tree | Error e -> write_error e) in - let* old_tree = find_tree t key in + let old_tree = find_tree t key in aux 0 old_tree let with_tree_exn ?clear ?retries ?allow_empty ?parents ?strategy ~info f t key = with_tree ?clear ?retries ?allow_empty ?strategy ?parents ~info f t key - >>= fail "with_tree_exn" + |> fail "with_tree_exn" let clone ~src ~dst = - let* () = - Head.find src >>= function + let () = + match Head.find src with | None -> Branch_store.remove (branch_store src) dst | Some h -> Branch_store.set (branch_store src) dst h.key in of_branch (repo src) dst let return_lcas r = function - | Error _ as e -> Lwt.return e - | Ok commits -> - Lwt_list.filter_map_p (Commit.of_key r) commits >|= Result.ok + | Error _ as e -> e + | Ok commits -> List.filter_map (Commit.of_key r) commits |> Result.ok let lcas ?max_depth ?n t1 t2 = - let* h1 = Head.get t1 in - let* h2 = Head.get t2 in + let h1 = Head.get t1 in + let h2 = Head.get t2 in Commits.lcas (commit_store t1) ?max_depth ?n h1.key h2.key - >>= return_lcas t1.repo + |> return_lcas t1.repo let lcas_with_commit t ?max_depth ?n c = - let* h = Head.get t in + let h = Head.get t in Commits.lcas (commit_store t) ?max_depth ?n h.key c.key - >>= return_lcas t.repo + |> return_lcas t.repo let lcas_with_branch t ?max_depth ?n b = - let* h = Head.get t in - let* head = Head.get { t with head_ref = `Branch b } in + let h = Head.get t in + let head = Head.get { t with head_ref = `Branch b } in Commits.lcas (commit_store t) ?max_depth ?n h.key head.key - >>= return_lcas t.repo + |> return_lcas t.repo type 'a merge = info:Info.f -> ?max_depth:int -> ?n:int -> 'a -> - (unit, Merge.conflict) result Lwt.t + (unit, Merge.conflict) result let merge_with_branch t ~info ?max_depth ?n other = [%log.debug "merge_with_branch %a" pp_branch other]; - Branch_store.find (branch_store t) other >>= function + match Branch_store.find (branch_store t) other with | None -> - Fmt.kstr Lwt.fail_invalid_arg - "merge_with_branch: %a is not a valid branch ID" pp_branch other + Fmt.kstr invalid_arg "merge_with_branch: %a is not a valid branch ID" + pp_branch other | Some c -> ( - Commit.of_key t.repo c >>= function - | None -> Lwt.fail_invalid_arg "invalid commit" + match Commit.of_key t.repo c with + | None -> invalid_arg "invalid commit" | Some c -> Head.merge ~into:t ~info ?max_depth ?n c) let merge_with_commit t ~info ?max_depth ?n other = @@ -1093,22 +1049,21 @@ module Make (B : Backend.S) = struct let t = Dst.empty () in if Src.nb_vertex g = 1 then match Src.vertex g with - | [ v ] -> ( - f v >|= function Some v -> Dst.add_vertex t v | None -> t) + | [ v ] -> ( match f v with Some v -> Dst.add_vertex t v | None -> t) | _ -> assert false else Src.fold_edges (fun x y t -> - let* t = t in - let* x = f x in - let+ y = f y in + let t = t in + let x = f x in + let y = f y in match (x, y) with | Some x, Some y -> let t = Dst.add_vertex t x in let t = Dst.add_vertex t y in Dst.add_edge t x y | _ -> t) - g (Lwt.return t) + g t end let history ?depth ?(min = []) ?(max = []) t = @@ -1116,16 +1071,16 @@ module Make (B : Backend.S) = struct let pred = function | `Commit k -> Commits.parents (commit_store t) k - >>= Lwt_list.filter_map_p (Commit.of_key t.repo) - >|= fun parents -> List.map (fun x -> `Commit x.key) parents - | _ -> Lwt.return_nil + |> List.filter_map (Commit.of_key t.repo) + |> fun parents -> List.map (fun x -> `Commit x.key) parents + | _ -> [] in - let* max = Head.find t >|= function Some h -> [ h ] | None -> max in + let max = Head.find t |> function Some h -> [ h ] | None -> max in let max = List.map (fun k -> `Commit k.key) max in let min = List.map (fun k -> `Commit k.key) min in - let* g = Gmap.Src.closure ?depth ~min ~max ~pred () in + let g = Gmap.Src.closure ?depth ~min ~max ~pred () in Gmap.filter_map - (function `Commit k -> Commit.of_key t.repo k | _ -> Lwt.return_none) + (function `Commit k -> Commit.of_key t.repo k | _ -> None) g module Heap = Binary_heap.Make (struct @@ -1144,42 +1099,41 @@ module Make (B : Backend.S) = struct Fmt.(Dump.option pp_int) depth n pp_path key]; let repo = repo t in - let* commit = Head.get t in + let commit = Head.get t in let heap = Heap.create ~dummy:(commit, 0) 0 in let () = Heap.add heap (commit, 0) in let rec search acc = - if Heap.is_empty heap || List.length acc = n then Lwt.return acc + if Heap.is_empty heap || List.length acc = n then acc else let current, current_depth = Heap.pop_minimum heap in let parents = Commit.parents current in let tree = Commit.tree current in - let* current_value = Tree.find tree key in + let current_value = Tree.find tree key in if List.length parents = 0 then - if current_value <> None then Lwt.return (current :: acc) - else Lwt.return acc + if current_value <> None then current :: acc else acc else let max_depth = match depth with | Some depth -> current_depth >= depth | None -> false in - let* found = - Lwt_list.for_all_p + let found = + List.for_all (fun hash -> - Commit.of_key repo hash >>= function + match Commit.of_key repo hash with | Some commit -> ( let () = if not max_depth then Heap.add heap (commit, current_depth + 1) in let tree = Commit.tree commit in - let+ e = Tree.find tree key in + let e = Tree.find tree key in match (e, current_value) with | Some x, Some y -> not (equal_contents x y) | Some _, None -> true | None, Some _ -> true | _, _ -> false) - | None -> Lwt.return_false) + | None -> false) parents in if found then search (current :: acc) else search acc @@ -1192,8 +1146,8 @@ module Make (B : Backend.S) = struct let mem t = B.Branch.mem (B.Repo.branch_t t) let find t br = - B.Branch.find (Repo.branch_t t) br >>= function - | None -> Lwt.return_none + match B.Branch.find (Repo.branch_t t) br with + | None -> None | Some h -> Commit.of_key t h let set t br h = B.Branch.set (B.Repo.branch_t t) br h.key @@ -1202,7 +1156,7 @@ module Make (B : Backend.S) = struct let watch t k ?init f = let init = match init with None -> None | Some h -> Some h.key in - let+ w = + let w = B.Branch.watch_key (Repo.branch_t t) k ?init (lift_head_diff t f) in fun () -> Branch_store.unwatch (Repo.branch_t t) w @@ -1214,14 +1168,13 @@ module Make (B : Backend.S) = struct | Some i -> Some (List.map (fun (k, v) -> (k, v.key)) i) in let f k v = lift_head_diff t (f k) v in - let+ w = B.Branch.watch (Repo.branch_t t) ?init f in + let w = B.Branch.watch (Repo.branch_t t) ?init f in fun () -> Branch_store.unwatch (Repo.branch_t t) w let err_not_found k = Fmt.kstr invalid_arg "Branch.get: %a not found" pp_branch k - let get t k = - find t k >>= function None -> err_not_found k | Some v -> Lwt.return v + let get t k = match find t k with None -> err_not_found k | Some v -> v let pp = pp_branch end @@ -1279,22 +1232,22 @@ struct in contents c [] - let set_tree (tree : Store.tree) key j : Store.tree Lwt.t = + let set_tree (tree : Store.tree) key j : Store.tree = let c = to_concrete_tree j in let c = Store.Tree.of_concrete c in Store.Tree.add_tree tree key c let get_tree (tree : Store.tree) key = - let* t = Store.Tree.get_tree tree key in - let+ c = Store.Tree.to_concrete t in + let t = Store.Tree.get_tree tree key in + let c = Store.Tree.to_concrete t in of_concrete_tree c let set t key j ~info = - set_tree (Store.Tree.empty ()) Store.Path.empty j >>= function + match set_tree (Store.Tree.empty ()) Store.Path.empty j with | tree -> Store.set_tree_exn ~info t key tree let get t key = - let* tree = Store.get_tree t key in + let tree = Store.get_tree t key in get_tree tree Store.Path.empty end diff --git a/src/irmin/store_intf.ml b/src/irmin/store_intf.ml index 09ba421064..3f710d1462 100644 --- a/src/irmin/store_intf.ml +++ b/src/irmin/store_intf.ml @@ -107,7 +107,7 @@ module type S_generic_key = sig type t = repo (** The type of repository handles. *) - val v : Conf.t -> t Lwt.t + val v : Conf.t -> t (** [v config] connects to a repository in a backend-specific manner. *) val config : t -> Conf.t @@ -116,10 +116,10 @@ module type S_generic_key = sig include Closeable with type _ t := t (** @inline *) - val heads : t -> commit list Lwt.t + val heads : t -> commit list (** [heads] is {!Head.list}. *) - val branches : t -> branch list Lwt.t + val branches : t -> branch list (** [branches] is {!Branch.list}. *) val export : @@ -128,7 +128,7 @@ module type S_generic_key = sig ?min:commit list -> ?max:[ `Head | `Max of commit list ] -> t -> - slice Lwt.t + slice (** [export t ~full ~depth ~min ~max] exports the store slice between [min] and [max], using at most [depth] history depth (starting from the max). @@ -143,7 +143,7 @@ module type S_generic_key = sig commits, nodes and contents, is exported, otherwise it is the commit history graph only. *) - val import : t -> slice -> (unit, [ `Msg of string ]) result Lwt.t + val import : t -> slice -> (unit, [ `Msg of string ]) result (** [import t s] imports the contents of the slice [s] in [t]. Does not modify branches. *) @@ -155,30 +155,30 @@ module type S_generic_key = sig [@@deriving irmin] (** The type for elements iterated over by {!iter}. *) - val default_pred_commit : t -> commit_key -> elt list Lwt.t - val default_pred_node : t -> node_key -> elt list Lwt.t - val default_pred_contents : t -> contents_key -> elt list Lwt.t + val default_pred_commit : t -> commit_key -> elt list + val default_pred_node : t -> node_key -> elt list + val default_pred_contents : t -> contents_key -> elt list val iter : ?cache_size:int -> min:elt list -> max:elt list -> - ?edge:(elt -> elt -> unit Lwt.t) -> - ?branch:(branch -> unit Lwt.t) -> - ?commit:(commit_key -> unit Lwt.t) -> - ?node:(node_key -> unit Lwt.t) -> - ?contents:(contents_key -> unit Lwt.t) -> - ?skip_branch:(branch -> bool Lwt.t) -> - ?skip_commit:(commit_key -> bool Lwt.t) -> - ?skip_node:(node_key -> bool Lwt.t) -> - ?skip_contents:(contents_key -> bool Lwt.t) -> - ?pred_branch:(t -> branch -> elt list Lwt.t) -> - ?pred_commit:(t -> commit_key -> elt list Lwt.t) -> - ?pred_node:(t -> node_key -> elt list Lwt.t) -> - ?pred_contents:(t -> contents_key -> elt list Lwt.t) -> + ?edge:(elt -> elt -> unit) -> + ?branch:(branch -> unit) -> + ?commit:(commit_key -> unit) -> + ?node:(node_key -> unit) -> + ?contents:(contents_key -> unit) -> + ?skip_branch:(branch -> bool) -> + ?skip_commit:(commit_key -> bool) -> + ?skip_node:(node_key -> bool) -> + ?skip_contents:(contents_key -> bool) -> + ?pred_branch:(t -> branch -> elt list) -> + ?pred_commit:(t -> commit_key -> elt list) -> + ?pred_node:(t -> node_key -> elt list) -> + ?pred_contents:(t -> contents_key -> elt list) -> ?rev:bool -> t -> - unit Lwt.t + unit (** [iter t] iterates in topological order over the closure graph of [t]. If [rev] is set (by default it is) the traversal is done in reverse order. @@ -219,31 +219,31 @@ module type S_generic_key = sig val breadth_first_traversal : ?cache_size:int -> max:elt list -> - ?branch:(branch -> unit Lwt.t) -> - ?commit:(commit_key -> unit Lwt.t) -> - ?node:(node_key -> unit Lwt.t) -> - ?contents:(contents_key -> unit Lwt.t) -> - ?pred_branch:(t -> branch -> elt list Lwt.t) -> - ?pred_commit:(t -> commit_key -> elt list Lwt.t) -> - ?pred_node:(t -> node_key -> elt list Lwt.t) -> - ?pred_contents:(t -> contents_key -> elt list Lwt.t) -> + ?branch:(branch -> unit) -> + ?commit:(commit_key -> unit) -> + ?node:(node_key -> unit) -> + ?contents:(contents_key -> unit) -> + ?pred_branch:(t -> branch -> elt list) -> + ?pred_commit:(t -> commit_key -> elt list) -> + ?pred_node:(t -> node_key -> elt list) -> + ?pred_contents:(t -> contents_key -> elt list) -> t -> - unit Lwt.t + unit end - val empty : repo -> t Lwt.t + val empty : repo -> t (** [empty repo] is a temporary, empty store. Becomes a normal temporary store after the first update. *) - val main : repo -> t Lwt.t + val main : repo -> t (** [main r] is a persistent store based on [r]'s main branch. This operation is cheap, can be repeated multiple times. *) - val of_branch : repo -> branch -> t Lwt.t + val of_branch : repo -> branch -> t (** [of_branch r name] is a persistent store based on the branch [name]. Similar to {!main}, but use [name] instead of {!Irmin.Branch.S.main}. *) - val of_commit : commit -> t Lwt.t + val of_commit : commit -> t (** [of_commit c] is a temporary store, based on the commit [c]. Temporary stores do not have stable names: instead they can be addressed @@ -256,7 +256,7 @@ module type S_generic_key = sig val repo : t -> repo (** [repo t] is the repository containing [t]. *) - val tree : t -> tree Lwt.t + val tree : t -> tree (** [tree t] is [t]'s current tree. Contents is not allowed at the root of the tree. *) @@ -277,11 +277,11 @@ module type S_generic_key = sig (** Managing the store's heads. *) module Head : sig - val list : repo -> commit list Lwt.t + val list : repo -> commit list (** [list t] is the list of all the heads in local store. Similar to [git rev-list --all]. *) - val find : t -> commit option Lwt.t + val find : t -> commit option (** [find t] is the current head of the store [t]. This works for both persistent and temporary branches. In the case of a persistent branch, this involves getting the the head associated with the branch, so this @@ -289,17 +289,17 @@ module type S_generic_key = sig current head. Returns [None] if the store has no contents. Similar to [git rev-parse HEAD]. *) - val get : t -> commit Lwt.t + val get : t -> commit (** Same as {!find} but raise [Invalid_argument] if the store does not have any contents. *) - val set : t -> commit -> unit Lwt.t + val set : t -> commit -> unit (** [set t h] updates [t]'s contents with the contents of the commit [h]. Can cause data loss as it discards the current contents. Similar to [git reset --hard ]. *) val fast_forward : - t -> ?max_depth:int -> ?n:int -> commit -> (unit, ff_error) result Lwt.t + t -> ?max_depth:int -> ?n:int -> commit -> (unit, ff_error) result (** [fast_forward t h] is similar to {!set} but the [t]'s head is updated to [h] only if [h] is stricly in the future of [t]'s current head. [max_depth] or [n] are used to limit the search space of the lowest @@ -314,8 +314,7 @@ module type S_generic_key = sig useful results. In that case. the operation can be retried using different parameters of [n] and [max_depth] to get better results. *) - val test_and_set : - t -> test:commit option -> set:commit option -> bool Lwt.t + val test_and_set : t -> test:commit option -> set:commit option -> bool (** Same as {!set} but check that the value is [test] before updating to [set]. Use {!set} or {!val-merge} instead if possible. *) @@ -325,7 +324,7 @@ module type S_generic_key = sig ?max_depth:int -> ?n:int -> commit -> - (unit, Merge.conflict) result Lwt.t + (unit, Merge.conflict) result (** [merge ~into:t ?max_head ?n commit] merges the contents of the commit associated to [commit] into [t]. [max_depth] is the maximal depth used for getting the lowest common ancestor. [n] is the maximum number of @@ -357,7 +356,7 @@ module type S_generic_key = sig info:info -> parents:commit_key list -> tree -> - commit Lwt.t + commit (** [v r i ~parents:p t] is the commit [c] such that: - [info c = i] @@ -384,11 +383,11 @@ module type S_generic_key = sig val key : commit -> commit_key (** [key c] is [c]'s key. *) - val of_key : repo -> commit_key -> commit option Lwt.t + val of_key : repo -> commit_key -> commit option (** [of_key r k] is the the commit object in [r] with key [k], or [None] if no such commit object exists. *) - val of_hash : repo -> hash -> commit option Lwt.t + val of_hash : repo -> hash -> commit option (** [of_hash r h] is the commit object in [r] with hash [h], or [None] if no such commit object is indexed in [r]. @@ -405,11 +404,11 @@ module type S_generic_key = sig val hash : contents -> hash (** [hash c] it [c]'s hash. *) - val of_key : repo -> contents_key -> contents option Lwt.t + val of_key : repo -> contents_key -> contents option (** [of_key r k] is the contents object in [r] with key [k], or [None] if no such contents object exists. *) - val of_hash : repo -> hash -> contents option Lwt.t + val of_hash : repo -> hash -> contents option (** [of_hash r h] is the contents object in [r] with hash [h], or [None] if no such contents object is indexed in [r]. @@ -449,11 +448,11 @@ module type S_generic_key = sig with {!of_concrete}) have no backend key until they are exported to a repository, and so will return [None]. *) - val find_key : Repo.t -> tree -> kinded_key option Lwt.t + val find_key : Repo.t -> tree -> kinded_key option (** [find_key r t] is the key of a tree object with the same hash as [t] in [r], if such a key exists and is indexed. *) - val of_key : Repo.t -> kinded_key -> tree option Lwt.t + val of_key : Repo.t -> kinded_key -> tree option (** [of_key r h] is the tree object in [r] having [h] as key, or [None] if no such tree object exists. *) @@ -471,7 +470,7 @@ module type S_generic_key = sig val kinded_hash : ?cache:bool -> tree -> kinded_hash (** [kinded_hash t] is [c]'s kinded hash. *) - val of_hash : Repo.t -> kinded_hash -> tree option Lwt.t + val of_hash : Repo.t -> kinded_hash -> tree option (** [of_hash r h] is the tree object in [r] with hash [h], or [None] if no such tree object is indexed in [r]. @@ -483,8 +482,8 @@ module type S_generic_key = sig type 'result producer := repo -> kinded_key -> - (tree -> (tree * 'result) Lwt.t) -> - (Proof.t * 'result) Lwt.t + (tree -> (tree * 'result)) -> + (Proof.t * 'result) (** [produce r h f] runs [f] on top of a real store [r], producing a proof and a result using the initial root hash [h]. @@ -499,8 +498,8 @@ module type S_generic_key = sig type 'result verifier := Proof.t -> - (tree -> (tree * 'result) Lwt.t) -> - (tree * 'result, verifier_error) result Lwt.t + (tree -> (tree * 'result)) -> + (tree * 'result, verifier_error) result (** [verify p f] runs [f] in checking mode. [f] is a function that takes a tree as input and returns a new version of the tree and a result. [p] is a proof, that is a minimal representation of the tree that contains what @@ -543,42 +542,42 @@ module type S_generic_key = sig (** {1 Reads} *) - val kind : t -> path -> [ `Contents | `Node ] option Lwt.t + val kind : t -> path -> [ `Contents | `Node ] option (** [kind] is {!Tree.kind} applied to [t]'s root tree. *) - val list : t -> path -> (step * tree) list Lwt.t + val list : t -> path -> (step * tree) list (** [list t] is {!Tree.list} applied to [t]'s root tree. *) - val mem : t -> path -> bool Lwt.t + val mem : t -> path -> bool (** [mem t] is {!Tree.mem} applied to [t]'s root tree. *) - val mem_tree : t -> path -> bool Lwt.t + val mem_tree : t -> path -> bool (** [mem_tree t] is {!Tree.mem_tree} applied to [t]'s root tree. *) - val find_all : t -> path -> (contents * metadata) option Lwt.t + val find_all : t -> path -> (contents * metadata) option (** [find_all t] is {!Tree.find_all} applied to [t]'s root tree. *) - val find : t -> path -> contents option Lwt.t + val find : t -> path -> contents option (** [find t] is {!Tree.find} applied to [t]'s root tree. *) - val get_all : t -> path -> (contents * metadata) Lwt.t + val get_all : t -> path -> contents * metadata (** [get_all t] is {!Tree.get_all} applied on [t]'s root tree. *) - val get : t -> path -> contents Lwt.t + val get : t -> path -> contents (** [get t] is {!Tree.get} applied to [t]'s root tree. *) - val find_tree : t -> path -> tree option Lwt.t + val find_tree : t -> path -> tree option (** [find_tree t] is {!Tree.find_tree} applied to [t]'s root tree. *) - val get_tree : t -> path -> tree Lwt.t + val get_tree : t -> path -> tree (** [get_tree t k] is {!Tree.get_tree} applied to [t]'s root tree. *) type kinded_key := [ `Contents of contents_key | `Node of node_key ] - val key : t -> path -> kinded_key option Lwt.t + val key : t -> path -> kinded_key option (** [id t k] *) - val hash : t -> path -> hash option Lwt.t + val hash : t -> path -> hash option (** [hash t k] *) (** {1 Updates} *) @@ -603,7 +602,7 @@ module type S_generic_key = sig t -> path -> contents -> - (unit, write_error) result Lwt.t + (unit, write_error) result (** [set t k ~info v] sets [k] to the value [v] in [t]. Discard any previous results but ensure that no operation is lost in the history. @@ -626,7 +625,7 @@ module type S_generic_key = sig t -> path -> contents -> - unit Lwt.t + unit (** [set_exn] is like {!set} but raise [Failure _] instead of using a result type. *) @@ -639,7 +638,7 @@ module type S_generic_key = sig t -> path -> tree -> - (unit, write_error) result Lwt.t + (unit, write_error) result (** [set_tree] is like {!set} but for trees. *) val set_tree_exn : @@ -651,7 +650,7 @@ module type S_generic_key = sig t -> path -> tree -> - unit Lwt.t + unit (** [set_tree] is like {!set_exn} but for trees. *) val remove : @@ -662,7 +661,7 @@ module type S_generic_key = sig info:Info.f -> t -> path -> - (unit, write_error) result Lwt.t + (unit, write_error) result (** [remove t ~info k] remove any bindings to [k] in [t]. The result is [Error `Too_many_retries] if the concurrent operations do @@ -677,7 +676,7 @@ module type S_generic_key = sig info:Info.f -> t -> path -> - unit Lwt.t + unit (** [remove_exn] is like {!remove} but raise [Failure _] instead of a using result type. *) @@ -691,7 +690,7 @@ module type S_generic_key = sig path -> test:contents option -> set:contents option -> - (unit, write_error) result Lwt.t + (unit, write_error) result (** [test_and_set ~test ~set] is like {!set} but it atomically checks that the tree is [test] before modifying it to [set]. @@ -715,7 +714,7 @@ module type S_generic_key = sig path -> test:contents option -> set:contents option -> - unit Lwt.t + unit (** [test_and_set_exn] is like {!test_and_set} but raise [Failure _] instead of using a result type. *) @@ -729,7 +728,7 @@ module type S_generic_key = sig path -> test:tree option -> set:tree option -> - (unit, write_error) result Lwt.t + (unit, write_error) result (** [test_and_set_tree] is like {!test_and_set} but for trees. *) val test_and_set_tree_exn : @@ -742,7 +741,7 @@ module type S_generic_key = sig path -> test:tree option -> set:tree option -> - unit Lwt.t + unit (** [test_and_set_tree_exn] is like {!test_and_set_exn} but for trees. *) val test_set_and_get : @@ -755,7 +754,7 @@ module type S_generic_key = sig path -> test:contents option -> set:contents option -> - (commit option, write_error) result Lwt.t + (commit option, write_error) result (** [test_set_and_get] is like {!test_and_set} except it also returns the commit associated with updating the store with the new value if the [test_and_set] is successful. No commit is returned if there was no update @@ -771,7 +770,7 @@ module type S_generic_key = sig path -> test:contents option -> set:contents option -> - commit option Lwt.t + commit option (** [test_set_and_get_exn] is like {!test_set_and_get} but raises [Failure _] instead. *) @@ -785,7 +784,7 @@ module type S_generic_key = sig path -> test:tree option -> set:tree option -> - (commit option, write_error) result Lwt.t + (commit option, write_error) result (** [test_set_and_get_tree] is like {!test_set_and_get} but for a {!tree} *) val test_set_and_get_tree_exn : @@ -798,7 +797,7 @@ module type S_generic_key = sig path -> test:tree option -> set:tree option -> - commit option Lwt.t + commit option (** [test_set_and_get_tree_exn] is like {!test_set_and_get_tree} but raises [Failure _] instead. *) @@ -812,7 +811,7 @@ module type S_generic_key = sig t -> path -> contents option -> - (unit, write_error) result Lwt.t + (unit, write_error) result (** [merge ~old] is like {!set} but merge the current tree and the new tree using [old] as ancestor in case of conflicts. @@ -836,7 +835,7 @@ module type S_generic_key = sig t -> path -> contents option -> - unit Lwt.t + unit (** [merge_exn] is like {!val-merge} but raise [Failure _] instead of using a result type. *) @@ -850,7 +849,7 @@ module type S_generic_key = sig t -> path -> tree option -> - (unit, write_error) result Lwt.t + (unit, write_error) result (** [merge_tree] is like {!merge_tree} but for trees. *) val merge_tree_exn : @@ -863,7 +862,7 @@ module type S_generic_key = sig t -> path -> tree option -> - unit Lwt.t + unit (** [merge_tree] is like {!merge_tree} but for trees. *) val with_tree : @@ -875,8 +874,8 @@ module type S_generic_key = sig info:Info.f -> t -> path -> - (tree option -> tree option Lwt.t) -> - (unit, write_error) result Lwt.t + (tree option -> tree option) -> + (unit, write_error) result (** [with_tree t k ~info f] replaces {i atomically} the subtree [v] under [k] in the store [t] by the contents of the tree [f v], using the commit info [info ()]. @@ -910,14 +909,14 @@ module type S_generic_key = sig info:Info.f -> t -> path -> - (tree option -> tree option Lwt.t) -> - unit Lwt.t + (tree option -> tree option) -> + unit (** [with_tree_exn] is like {!with_tree} but raise [Failure _] instead of using a return type. *) (** {1 Clones} *) - val clone : src:t -> dst:branch -> t Lwt.t + val clone : src:t -> dst:branch -> t (** [clone ~src ~dst] makes [dst] points to [Head.get src]. [dst] is created if needed. Remove the current contents en [dst] if [src] is {!empty}. *) @@ -926,7 +925,7 @@ module type S_generic_key = sig type watch (** The type for store watches. *) - val watch : t -> ?init:commit -> (commit Diff.t -> unit Lwt.t) -> watch Lwt.t + val watch : t -> ?init:commit -> (commit Diff.t -> unit) -> watch (** [watch t f] calls [f] every time the contents of [t]'s head is updated. {b Note:} even if [f] might skip some head updates, it will never be @@ -934,16 +933,12 @@ module type S_generic_key = sig we ensure that the previous one ended before calling the next one. *) val watch_key : - t -> - path -> - ?init:commit -> - ((commit * tree) Diff.t -> unit Lwt.t) -> - watch Lwt.t + t -> path -> ?init:commit -> ((commit * tree) Diff.t -> unit) -> watch (** [watch_key t key f] calls [f] every time the [key]'s value is added, removed or updated. If the current branch is deleted, no signal is sent to the watcher. *) - val unwatch : watch -> unit Lwt.t + val unwatch : watch -> unit (** [unwatch w] disable [w]. Return once the [w] is fully disabled. *) (** {1 Merges and Common Ancestors} *) @@ -953,7 +948,7 @@ module type S_generic_key = sig ?max_depth:int -> ?n:int -> 'a -> - (unit, Merge.conflict) result Lwt.t + (unit, Merge.conflict) result (** The type for merge functions. *) val merge_into : into:t -> t merge @@ -968,7 +963,7 @@ module type S_generic_key = sig (** Same as {!val-merge} but with a commit_id. *) val lcas : - ?max_depth:int -> ?n:int -> t -> t -> (commit list, lca_error) result Lwt.t + ?max_depth:int -> ?n:int -> t -> t -> (commit list, lca_error) result (** [lca ?max_depth ?n msg t1 t2] returns the collection of least common ancestors between the heads of [t1] and [t2] branches. @@ -979,19 +974,11 @@ module type S_generic_key = sig found. *) val lcas_with_branch : - t -> - ?max_depth:int -> - ?n:int -> - branch -> - (commit list, lca_error) result Lwt.t + t -> ?max_depth:int -> ?n:int -> branch -> (commit list, lca_error) result (** Same as {!lcas} but takes a branch ID as argument. *) val lcas_with_commit : - t -> - ?max_depth:int -> - ?n:int -> - commit -> - (commit list, lca_error) result Lwt.t + t -> ?max_depth:int -> ?n:int -> commit -> (commit list, lca_error) result (** Same as {!lcas} but takes a commmit as argument. *) (** {1 History} *) @@ -1000,12 +987,12 @@ module type S_generic_key = sig (** An history is a DAG of heads. *) val history : - ?depth:int -> ?min:commit list -> ?max:commit list -> t -> History.t Lwt.t + ?depth:int -> ?min:commit list -> ?max:commit list -> t -> History.t (** [history ?depth ?min ?max t] is a view of the history of the store [t], of depth at most [depth], starting from the [t]'s head (or from [max] if the head is not set) and stopping at [min] if specified. *) - val last_modified : ?depth:int -> ?n:int -> t -> path -> commit list Lwt.t + val last_modified : ?depth:int -> ?n:int -> t -> path -> commit list (** [last_modified ?number c k] is the list of the last [number] commits that modified [path], in ascending order of date. [depth] is the maximum depth to be explored in the commit graph, if any. Default value for [number] is @@ -1018,39 +1005,35 @@ module type S_generic_key = sig Manipulate relations between {{!branch} branches} and {{!commit} commits}. *) - val mem : repo -> branch -> bool Lwt.t + val mem : repo -> branch -> bool (** [mem r b] is true iff [b] is present in [r]. *) - val find : repo -> branch -> commit option Lwt.t + val find : repo -> branch -> commit option (** [find r b] is [Some c] iff [c] is bound to [b] in [t]. It is [None] if [b] is not present in [t]. *) - val get : repo -> branch -> commit Lwt.t + val get : repo -> branch -> commit (** [get t b] is similar to {!find} but raise [Invalid_argument] if [b] is not present in [t]. *) - val set : repo -> branch -> commit -> unit Lwt.t + val set : repo -> branch -> commit -> unit (** [set t b c] bounds [c] to [b] in [t]. *) - val remove : repo -> branch -> unit Lwt.t + val remove : repo -> branch -> unit (** [remove t b] removes [b] from [t]. *) - val list : repo -> branch list Lwt.t + val list : repo -> branch list (** [list t] is the list of branches present in [t]. *) val watch : - repo -> - branch -> - ?init:commit -> - (commit Diff.t -> unit Lwt.t) -> - watch Lwt.t + repo -> branch -> ?init:commit -> (commit Diff.t -> unit) -> watch (** [watch t b f] calls [f] on every change in [b]. *) val watch_all : repo -> ?init:(branch * commit) list -> - (branch -> commit Diff.t -> unit Lwt.t) -> - watch Lwt.t + (branch -> commit Diff.t -> unit) -> + watch (** [watch_all t f] calls [f] on every branch-related change in [t], including creation/deletion events. *) @@ -1087,8 +1070,8 @@ module type S_generic_key = sig (** {2 Converters to backend types} *) val of_backend_node : repo -> Backend.Node.value -> node - val to_backend_node : node -> Backend.Node.value Lwt.t - val to_backend_portable_node : node -> Backend.Node_portable.t Lwt.t + val to_backend_node : node -> Backend.Node.value + val to_backend_portable_node : node -> Backend.Node_portable.t val to_backend_commit : commit -> Backend.Commit.value (** [to_backend_commit c] is the backend commit object associated with the @@ -1099,8 +1082,7 @@ module type S_generic_key = sig (** [of_backend_commit r k c] is the commit associated with the backend commit object [c] that hash key [k] in [r]. *) - val save_contents : - [> write ] Backend.Contents.t -> contents -> contents_key Lwt.t + val save_contents : [> write ] Backend.Contents.t -> contents -> contents_key (** Save a content into the database *) val save_tree : @@ -1109,7 +1091,7 @@ module type S_generic_key = sig [> write ] Backend.Contents.t -> [> read_write ] Backend.Node.t -> tree -> - kinded_key Lwt.t + kinded_key (** Save a tree into the database. Does not do any reads. When [clear] is set (the default), the tree cache is emptied upon the @@ -1117,7 +1099,7 @@ module type S_generic_key = sig (** {Deprecated} *) - val master : repo -> t Lwt.t + val master : repo -> t [@@ocaml.deprecated "Use `main` instead."] (** @deprecated Use {!main} instead *) end @@ -1165,17 +1147,16 @@ module type Json_tree = functor val to_concrete_tree : t -> Store.Tree.concrete val of_concrete_tree : Store.Tree.concrete -> t - val get_tree : Store.tree -> Store.path -> t Lwt.t + val get_tree : Store.tree -> Store.path -> t (** Extract a [json] value from tree at the given key. *) - val set_tree : Store.tree -> Store.path -> t -> Store.tree Lwt.t + val set_tree : Store.tree -> Store.path -> t -> Store.tree (** Project a [json] value onto a tree at the given key. *) - val get : Store.t -> Store.path -> t Lwt.t + val get : Store.t -> Store.path -> t (** Extract a [json] value from a store at the given key. *) - val set : - Store.t -> Store.path -> t -> info:(unit -> Store.info) -> unit Lwt.t + val set : Store.t -> Store.path -> t -> info:(unit -> Store.info) -> unit (** Project a [json] value onto a store at the given key. *) end diff --git a/src/irmin/store_properties_intf.ml b/src/irmin/store_properties_intf.ml index ce56bf71dd..71ab8e76ef 100644 --- a/src/irmin/store_properties_intf.ml +++ b/src/irmin/store_properties_intf.ml @@ -19,7 +19,7 @@ open Import module type Batch = sig type 'a t - val batch : read t -> ([ read | write ] t -> 'a Lwt.t) -> 'a Lwt.t + val batch : read t -> ([ read | write ] t -> 'a) -> 'a (** [batch t f] applies the writes in [f] in a separate batch. The exact guarantees depend on the implementation. *) end @@ -27,7 +27,7 @@ end module type Closeable = sig type 'a t - val close : 'a t -> unit Lwt.t + val close : 'a t -> unit (** [close t] frees up all the resources associated with [t]. Any operations run on a closed handle will raise [Closed]. *) end @@ -35,7 +35,7 @@ end module type Of_config = sig type 'a t - val v : Conf.t -> read t Lwt.t + val v : Conf.t -> read t (** [v config] is a function returning fresh store handles, with the configuration [config], which is provided by the backend. *) end @@ -43,7 +43,7 @@ end module type Clearable = sig type 'a t - val clear : 'a t -> unit Lwt.t + val clear : 'a t -> unit (** Clear the store. This operation is expected to be slow. *) end diff --git a/src/irmin/sync.ml b/src/irmin/sync.ml index 513c72b689..bc6e9db936 100644 --- a/src/irmin/sync.ml +++ b/src/irmin/sync.ml @@ -19,7 +19,7 @@ include Sync_intf module type REMOTE = Remote.S -let invalid_argf fmt = Fmt.kstr Lwt.fail_invalid_arg fmt +let invalid_argf fmt = Fmt.kstr invalid_arg fmt let src = Logs.Src.create "irmin.sync" ~doc:"Irmin remote sync" module Log = (val Logs.src_log src : Logs.LOG) @@ -51,29 +51,27 @@ module Make (S : Store.Generic_key.S) = struct let conv_node_v = Type.unstage (conv RP.Node.Val.t SP.Node.Val.t) in let conv_commit_k = Type.unstage (conv RP.Commit.Hash.t SP.Commit.Hash.t) in let conv_commit_v = Type.unstage (conv RP.Commit.Val.t SP.Commit.Val.t) in - let* s = SP.Slice.empty () in - let* () = - RP.Slice.iter r (function - | `Contents (k, v) -> ( - let k = conv_contents_k k in - let v = conv_contents_v v in - match (k, v) with - | Ok k, Ok v -> SP.Slice.add s (`Contents (k, v)) - | _ -> Lwt.return_unit) - | `Node (k, v) -> ( - let k = conv_node_k k in - let v = conv_node_v v in - match (k, v) with - | Ok k, Ok v -> SP.Slice.add s (`Node (k, v)) - | _ -> Lwt.return_unit) - | `Commit (k, v) -> ( - let k = conv_commit_k k in - let v = conv_commit_v v in - match (k, v) with - | Ok k, Ok v -> SP.Slice.add s (`Commit (k, v)) - | _ -> Lwt.return_unit)) - in - Lwt.return s + let s = SP.Slice.empty () in + RP.Slice.iter r (function + | `Contents (k, v) -> ( + let k = conv_contents_k k in + let v = conv_contents_v v in + match (k, v) with + | Ok k, Ok v -> SP.Slice.add s (`Contents (k, v)) + | _ -> ()) + | `Node (k, v) -> ( + let k = conv_node_k k in + let v = conv_node_v v in + match (k, v) with + | Ok k, Ok v -> SP.Slice.add s (`Node (k, v)) + | _ -> ()) + | `Commit (k, v) -> ( + let k = conv_commit_k k in + let v = conv_commit_v v in + match (k, v) with + | Ok k, Ok v -> SP.Slice.add s (`Commit (k, v)) + | _ -> ())); + s let convs src dst l = let conv = Type.unstage (conv src dst) in @@ -106,43 +104,43 @@ module Make (S : Store.Generic_key.S) = struct let conv = Type.unstage (conv R.(commit_t r_repo) S.(commit_t s_repo)) in - let* min = S.Repo.heads s_repo in + let min = S.Repo.heads s_repo in let min = convs S.(commit_t s_repo) R.(commit_t r_repo) min in - R.Head.find r >>= function - | None -> Lwt.return (Ok `Empty) + match R.Head.find r with + | None -> Ok `Empty | Some h -> ( - let* r_slice = + let r_slice = R.Repo.export (R.repo r) ?depth ~min ~max:(`Max [ h ]) in - let* s_slice = + let s_slice = convert_slice (module R.Backend) (module S.Backend) r_slice in - S.Repo.import s_repo s_slice >|= function + match S.Repo.import s_repo s_slice with | Error e -> Error e | Ok () -> ( match conv h with Ok h -> Ok (`Head h) | Error e -> Error e))) | S.E e -> ( match S.status t with - | `Empty | `Commit _ -> Lwt.return (Ok `Empty) + | `Empty | `Commit _ -> Ok `Empty | `Branch br -> ( [%log.debug "Fetching branch %a" pp_branch br]; - let* g = B.v (S.repo t) in - B.fetch g ?depth e br >>= function - | Error _ as e -> Lwt.return e + let g = B.v (S.repo t) in + match B.fetch g ?depth e br with + | Error _ as e -> e | Ok (Some key) -> ( [%log.debug "Fetched %a" pp_commit_key key]; - S.Commit.of_key (S.repo t) key >|= function + match S.Commit.of_key (S.repo t) key with | None -> Ok `Empty | Some x -> Ok (`Head x)) | Ok None -> ( - S.Head.find t >>= function - | Some h -> Lwt.return (Ok (`Head h)) - | None -> Lwt.return (Ok `Empty)))) - | _ -> Lwt.return (Error (`Msg "fetch operation is not available")) + match S.Head.find t with + | Some h -> Ok (`Head h) + | None -> Ok `Empty))) + | _ -> Error (`Msg "fetch operation is not available") let fetch_exn t ?depth remote = - fetch t ?depth remote >>= function - | Ok h -> Lwt.return h + match fetch t ?depth remote with + | Ok h -> h | Error (`Msg e) -> invalid_argf "Sync.fetch_exn: %s" e type pull_error = [ `Msg of string | Merge.conflict ] @@ -151,21 +149,23 @@ module Make (S : Store.Generic_key.S) = struct | `Msg s -> Fmt.string ppf s | `Conflict c -> Fmt.pf ppf "conflict: %s" c - let pull t ?depth remote kind : (status, pull_error) result Lwt.t = - fetch t ?depth remote >>= function - | Error e -> Lwt.return (Error (e :> pull_error)) + let pull t ?depth remote kind : (status, pull_error) result = + match fetch t ?depth remote with + | Error e -> Error (e :> pull_error) | Ok (`Head k) -> ( match kind with - | `Set -> S.Head.set t k >|= fun () -> Ok (`Head k) + | `Set -> + S.Head.set t k; + Ok (`Head k) | `Merge info -> ( - S.Head.merge ~into:t ~info k >>= function - | Ok () -> Lwt.return (Ok (`Head k)) - | Error e -> Lwt.return (Error (e :> pull_error)))) - | Ok `Empty -> Lwt.return (Ok `Empty) + match S.Head.merge ~into:t ~info k with + | Ok () -> Ok (`Head k) + | Error e -> Error (e :> pull_error))) + | Ok `Empty -> Ok `Empty let pull_exn t ?depth remote kind = - pull t ?depth remote kind >>= function - | Ok x -> Lwt.return x + match pull t ?depth remote kind with + | Ok x -> x | Error e -> invalid_argf "Sync.pull_exn: %a" pp_pull_error e type push_error = [ `Msg of string | `Detached_head ] @@ -178,44 +178,44 @@ module Make (S : Store.Generic_key.S) = struct [%log.debug "push"]; match remote with | Store.Store ((module R), r) -> ( - S.Head.find t >>= function - | None -> Lwt.return (Ok `Empty) + match S.Head.find t with + | None -> Ok `Empty | Some h -> ( [%log.debug "push store"]; - let* min = R.Repo.heads (R.repo r) in + let min = R.Repo.heads (R.repo r) in let r_repo = R.repo r in let s_repo = S.repo t in let min = convs R.(commit_t r_repo) S.(commit_t s_repo) min in let conv = Type.unstage (conv S.(commit_t s_repo) R.(commit_t r_repo)) in - let* s_slice = S.Repo.export (S.repo t) ?depth ~min in - let* r_slice = + let s_slice = S.Repo.export (S.repo t) ?depth ~min in + let r_slice = convert_slice (module S.Backend) (module R.Backend) s_slice in - R.Repo.import (R.repo r) r_slice >>= function - | Error e -> Lwt.return (Error (e :> push_error)) + match R.Repo.import (R.repo r) r_slice with + | Error e -> Error (e :> push_error) | Ok () -> ( match conv h with - | Error e -> Lwt.return (Error (e :> push_error)) + | Error e -> Error (e :> push_error) | Ok h -> - R.Head.set r h >>= fun () -> - let+ head = S.Head.get t in + R.Head.set r h; + let head = S.Head.get t in Ok (`Head head)))) | S.E e -> ( match S.status t with - | `Empty -> Lwt.return (Ok `Empty) - | `Commit _ -> Lwt.return (Error `Detached_head) + | `Empty -> Ok `Empty + | `Commit _ -> Error `Detached_head | `Branch br -> ( - let* head = S.of_branch (S.repo t) br >>= S.Head.get in - let* g = B.v (S.repo t) in - B.push g ?depth e br >>= function - | Ok () -> Lwt.return (Ok (`Head head)) - | Error err -> Lwt.return (Error (err :> push_error)))) - | _ -> Lwt.return (Error (`Msg "push operation is not available")) + let head = S.of_branch (S.repo t) br |> S.Head.get in + let g = B.v (S.repo t) in + match B.push g ?depth e br with + | Ok () -> Ok (`Head head) + | Error err -> Error (err :> push_error))) + | _ -> Error (`Msg "push operation is not available") let push_exn t ?depth remote = - push t ?depth remote >>= function - | Ok x -> Lwt.return x + match push t ?depth remote with + | Ok x -> x | Error e -> invalid_argf "Sync.push_exn: %a" pp_push_error e end diff --git a/src/irmin/sync_intf.ml b/src/irmin/sync_intf.ml index 1260e8665c..5818607aa7 100644 --- a/src/irmin/sync_intf.ml +++ b/src/irmin/sync_intf.ml @@ -36,13 +36,13 @@ module type S = sig (** [pp_status] pretty-prints return statuses. *) val fetch : - db -> ?depth:int -> Remote.t -> (status, [ `Msg of string ]) result Lwt.t + db -> ?depth:int -> Remote.t -> (status, [ `Msg of string ]) result (** [fetch t ?depth r] populate the local store [t] with objects from the remote store [r], using [t]'s current branch. The [depth] parameter limits the history depth. Return [`Empty] if either the local or remote store do not have a valid head. *) - val fetch_exn : db -> ?depth:int -> Remote.t -> status Lwt.t + val fetch_exn : db -> ?depth:int -> Remote.t -> status (** Same as {!fetch} but raise [Invalid_argument] if either the local or remote store do not have a valid head. *) @@ -57,7 +57,7 @@ module type S = sig ?depth:int -> Remote.t -> [ `Merge of unit -> info | `Set ] -> - (status, pull_error) result Lwt.t + (status, pull_error) result (** [pull t ?depth r s] is similar to {{!Sync.fetch} fetch} but it also updates [t]'s current branch. [s] is the update strategy: @@ -65,11 +65,7 @@ module type S = sig - [`Set] uses [S.Head.set]. *) val pull_exn : - db -> - ?depth:int -> - Remote.t -> - [ `Merge of unit -> info | `Set ] -> - status Lwt.t + db -> ?depth:int -> Remote.t -> [ `Merge of unit -> info | `Set ] -> status (** Same as {!pull} but raise [Invalid_arg] in case of conflict. *) type push_error = [ `Msg of string | `Detached_head ] @@ -78,7 +74,7 @@ module type S = sig val pp_push_error : push_error Fmt.t (** [pp_push_error] pretty-prints push errors. *) - val push : db -> ?depth:int -> Remote.t -> (status, push_error) result Lwt.t + val push : db -> ?depth:int -> Remote.t -> (status, push_error) result (** [push t ?depth r] populates the remote store [r] with objects from the current store [t], using [t]'s current branch. If [b] is [t]'s current branch, [push] also updates the head of [b] in [r] to be the same as in @@ -87,7 +83,7 @@ module type S = sig {b Note:} {e Git} semantics is to update [b] only if the new head if more recent. This is not the case in {e Irmin}. *) - val push_exn : db -> ?depth:int -> Remote.t -> status Lwt.t + val push_exn : db -> ?depth:int -> Remote.t -> status (** Same as {!push} but raise [Invalid_argument] if an error happens. *) end diff --git a/src/irmin/tree.ml b/src/irmin/tree.ml index 7090c53e93..0c7fd9c476 100644 --- a/src/irmin/tree.ml +++ b/src/irmin/tree.ml @@ -24,9 +24,9 @@ module Log = (val Logs.src_log src : Logs.LOG) type fuzzy_bool = False | True | Maybe type ('a, 'r) cont = ('a -> 'r) -> 'r -type ('a, 'r) cont_lwt = ('a, 'r Lwt.t) cont +type ('a, 'r) cont_lwt = ('a, 'r) cont -let ok x = Lwt.return (Ok x) +let ok x = Ok x (* assume l1 and l2 are key-sorted *) let alist_iter2 compare_k f l1 l2 = @@ -53,7 +53,7 @@ let alist_iter2 compare_k f l1 l2 = let alist_iter2_lwt compare_k f l1 l2 = let l3 = ref [] in alist_iter2 compare_k (fun left right -> l3 := f left right :: !l3) l1 l2; - Lwt_list.iter_s (fun b -> b >>= fun () -> Lwt.return_unit) (List.rev !l3) + List.iter (fun b -> b ()) (List.rev !l3) exception Backend_invariant_violation of string exception Assertion_failure of string @@ -173,9 +173,9 @@ module Make (P : Backend.S) = struct [ `Dangling_hash of hash | `Pruned_hash of hash | `Portable_value ] type 'a or_error = ('a, error) result - type 'a force = [ `True | `False of path -> 'a -> 'a Lwt.t ] + type 'a force = [ `True | `False of path -> 'a -> 'a ] type uniq = [ `False | `True | `Marks of marks ] - type ('a, 'b) folder = path -> 'b -> 'a -> 'a Lwt.t + type ('a, 'b) folder = path -> 'b -> 'a -> 'a type depth = [ `Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int ] [@@deriving irmin] @@ -326,7 +326,7 @@ module Make (P : Backend.S) = struct let value_of_key ~cache t repo k = cnt.contents_find <- cnt.contents_find + 1; let h = P.Contents.Key.to_hash k in - let+ v_opt = P.Contents.find (P.Repo.contents_t repo) k in + let v_opt = P.Contents.find (P.Repo.contents_t repo) k in Option.iter (Env.add_contents_from_store t.info.env h) v_opt; match v_opt with | None -> err_dangling_hash h @@ -341,12 +341,12 @@ module Make (P : Backend.S) = struct match t.v with | Value _ -> assert false (* [cached_value == None] *) | Key (repo, k) -> value_of_key ~cache t repo k - | Pruned h -> err_pruned_hash h |> Lwt.return) + | Pruned h -> err_pruned_hash h) let force = to_value ~cache:true let force_exn t = - let+ v = force t in + let v = force t in get_ok "force" v let equal (x : t) (y : t) = @@ -371,15 +371,15 @@ module Make (P : Backend.S) = struct let f ~old x y = let old = Merge.bind_promise old (fun old () -> - let+ c = to_value ~cache:true old >|= Option.of_result in + let c = to_value ~cache:true old |> Option.of_result in Ok (Some c)) in match merge_env x.info.env y.info.env with - | Error _ as e -> Lwt.return e + | Error _ as e -> e | Ok env -> ( - let* x = to_value ~cache:true x >|= Option.of_result in - let* y = to_value ~cache:true y >|= Option.of_result in - Merge.(f P.Contents.Val.merge) ~old x y >|= function + let x = to_value ~cache:true x |> Option.of_result in + let y = to_value ~cache:true y |> Option.of_result in + match Merge.(f P.Contents.Val.merge) ~old x y with | Ok (Some c) -> Ok (of_value ~env c) | Ok None -> Error (`Conflict "empty contents") | Error _ as e -> e) @@ -389,12 +389,12 @@ module Make (P : Backend.S) = struct let fold ~force ~cache ~path f_value f_tree t acc = match force with | `True -> - let* c = to_value ~cache t in - f_value path (get_ok "fold" c) acc >>= f_tree path + let c = to_value ~cache t in + f_value path (get_ok "fold" c) acc |> f_tree path | `False skip -> ( match cached_value t with | None -> skip path acc - | Some c -> f_value path c acc >>= f_tree path) + | Some c -> f_value path c acc |> f_tree path) end module Node = struct @@ -952,7 +952,7 @@ module Make (P : Backend.S) = struct | Some v -> ok v | None -> ( cnt.node_find <- cnt.node_find + 1; - let+ v_opt = P.Node.find (P.Repo.node_t repo) k in + let v_opt = P.Node.find (P.Repo.node_t repo) k in let h = P.Node.Key.to_hash k in let v_opt = Option.map (Env.add_node_from_store t.info.env h) v_opt in match v_opt with @@ -971,16 +971,16 @@ module Make (P : Backend.S) = struct | Any -> ( match t.v with | Key _ | Value (_, _, None) -> assert false - | Pruned h -> err_pruned_hash h |> Lwt.return - | Portable_dirty _ -> err_portable_value |> Lwt.return + | Pruned h -> err_pruned_hash h + | Portable_dirty _ -> err_portable_value | Map _ | Value (_, _, Some _) -> invalid_arg "Tree.Node.to_value: the supplied node has not been written to \ disk. Either export it or convert it to a portable value \ instead.") - let to_portable_value_aux ~cache ~value_of_key ~return ~bind:( let* ) t = - let ok x = return (Ok x) in + let to_portable_value_aux ~cache ~value_of_key t = + let ok x = Ok x in match (Scan.cascade t [ @@ -1002,8 +1002,8 @@ module Make (P : Backend.S) = struct | Node _ -> assert false | Pnode x -> ok x) | Repo_key (repo, k) -> - let* value_res = value_of_key ~cache t repo k in - Result.map P.Node_portable.of_node value_res |> return + let value_res = value_of_key ~cache t repo k in + Result.map P.Node_portable.of_node value_res | Value_dirty (_repo, v, um) -> hash_preimage_of_updates ~cache t (Node v) um (function | Node x -> ok (Portable.of_node x) @@ -1012,10 +1012,9 @@ module Make (P : Backend.S) = struct hash_preimage_of_map ~cache t m (function | Node x -> ok (Portable.of_node x) | Pnode x -> ok x) - | Pruned h -> err_pruned_hash h |> return + | Pruned h -> err_pruned_hash h - let to_portable_value = - to_portable_value_aux ~value_of_key ~return:Lwt.return ~bind:Lwt.bind + let to_portable_value = to_portable_value_aux ~value_of_key let to_map ~cache t = let of_maps m updates = @@ -1068,13 +1067,13 @@ module Make (P : Backend.S) = struct | Map m -> ok m | Repo_value (repo, v) -> ok (of_value repo v None) | Repo_key (repo, k) -> ( - value_of_key ~cache t repo k >|= function + match value_of_key ~cache t repo k with | Error _ as e -> e | Ok v -> Ok (of_value repo v None)) | Value_dirty (repo, v, um) -> ok (of_value repo v (Some um)) | Portable p -> ok (of_portable_value p None) | Portable_dirty (p, um) -> ok (of_portable_value p (Some um)) - | Pruned h -> err_pruned_hash h |> Lwt.return + | Pruned h -> err_pruned_hash h let contents_equal ((c1, m1) as x1) ((c2, m2) as x2) = x1 == x2 || (Contents.equal c1 c2 && equal_metadata m1 m2) @@ -1139,19 +1138,19 @@ module Make (P : Backend.S) = struct | `pruned ] Scan.t) with - | Map m -> StepMap.cardinal m |> Lwt.return - | Value v -> P.Node.Val.length v |> Lwt.return - | Portable p -> P.Node_portable.length p |> Lwt.return + | Map m -> StepMap.cardinal m + | Value v -> P.Node.Val.length v + | Portable p -> P.Node_portable.length p | Repo_key (repo, k) -> - value_of_key ~cache t repo k >|= get_ok "length" >|= P.Node.Val.length + value_of_key ~cache t repo k |> get_ok "length" |> P.Node.Val.length | Value_dirty (_repo, v, um) -> hash_preimage_of_updates ~cache t (Node v) um (function - | Node x -> P.Node.Val.length x |> Lwt.return - | Pnode x -> P.Node_portable.length x |> Lwt.return) + | Node x -> P.Node.Val.length x + | Pnode x -> P.Node_portable.length x) | Portable_dirty (p, um) -> hash_preimage_of_updates ~cache t (Pnode p) um (function | Node _ -> assert false - | Pnode x -> P.Node_portable.length x |> Lwt.return) + | Pnode x -> P.Node_portable.length x) | Pruned h -> pruned_hash_exn "length" h let length ~cache t = @@ -1183,7 +1182,7 @@ module Make (P : Backend.S) = struct | Portable_dirty (p, um) -> Portable_value.is_empty_after_updates ~cache p um - let findv_aux ~cache ~value_of_key ~return ~bind:( let* ) ctx t step = + let findv_aux ~cache ~value_of_key ctx t step = let of_map m = try Some (StepMap.find step m) with Not_found -> None in let of_value = Regular_value.findv ~cache ~env:t.info.env step t in let of_portable = Portable_value.findv ~cache ~env:t.info.env step t () in @@ -1208,31 +1207,30 @@ module Make (P : Backend.S) = struct | `pruned ] Scan.t) with - | Map m -> return (of_map m) - | Repo_value (repo, v) -> return (of_value repo v) + | Map m -> of_map m + | Repo_value (repo, v) -> of_value repo v | Repo_key (repo, k) -> - let* v = value_of_key ~cache t repo k in + let v = value_of_key ~cache t repo k in let v = get_ok ctx v in - return (of_value repo v) + of_value repo v | Value_dirty (repo, v, um) -> ( match StepMap.find_opt step um with - | Some (Add v) -> return (Some v) - | Some Remove -> return None - | None -> return (of_value repo v)) - | Portable p -> return (of_portable p) + | Some (Add v) -> Some v + | Some Remove -> None + | None -> of_value repo v) + | Portable p -> of_portable p | Portable_dirty (p, um) -> ( match StepMap.find_opt step um with - | Some (Add v) -> return (Some v) - | Some Remove -> return None - | None -> return (of_portable p)) + | Some (Add v) -> Some v + | Some Remove -> None + | None -> of_portable p) | Pruned h -> pruned_hash_exn ctx h in match t.info.findv_cache with | None -> of_t () - | Some m -> ( - match of_map m with None -> of_t () | Some _ as r -> return r) + | Some m -> ( match of_map m with None -> of_t () | Some _ as r -> r) - let findv = findv_aux ~value_of_key ~return:Lwt.return ~bind:Lwt.bind + let findv = findv_aux ~value_of_key let seq_of_map ?(offset = 0) ?length m : (step * elt) Seq.t = let take seq = @@ -1240,7 +1238,7 @@ module Make (P : Backend.S) = struct in StepMap.to_seq m |> Seq.drop offset |> take - let seq ?offset ?length ~cache t : (step * elt) Seq.t or_error Lwt.t = + let seq ?offset ?length ~cache t : (step * elt) Seq.t or_error = let env = t.info.env in match (Scan.cascade t @@ -1266,20 +1264,20 @@ module Make (P : Backend.S) = struct | Repo_value (repo, v) -> ok (Regular_value.seq ~env ?offset ?length ~cache repo v) | Repo_key (repo, k) -> ( - value_of_key ~cache t repo k >>= function - | Error _ as e -> Lwt.return e + match value_of_key ~cache t repo k with + | Error _ as e -> e | Ok v -> ok (Regular_value.seq ~env ?offset ?length ~cache repo v)) | Value_dirty _ | Portable_dirty _ -> ( - to_map ~cache t >>= function - | Error _ as e -> Lwt.return e + match to_map ~cache t with + | Error _ as e -> e | Ok m -> ok (seq_of_map ?offset ?length m)) | Portable p -> ok (Portable_value.seq ~env ?offset ?length ~cache () p) - | Pruned h -> err_pruned_hash h |> Lwt.return + | Pruned h -> err_pruned_hash h let bindings ~cache t = (* XXX: If [t] is value, no need to [to_map]. Let's remove and inline this into Tree.entries. *) - to_map ~cache t >|= function + match to_map ~cache t with | Error _ as e -> e | Ok m -> Ok (StepMap.bindings m) @@ -1319,7 +1317,7 @@ module Make (P : Backend.S) = struct tree:(acc, _) folder -> t -> acc -> - acc Lwt.t = + acc = fun ~order ~force ~cache ~uniq ~pre ~post ~path ?depth ~node ~contents ~tree t acc -> let env = t.info.env in @@ -1331,33 +1329,33 @@ module Make (P : Backend.S) = struct in let pre path bindings acc = match pre with - | None -> Lwt.return acc + | None -> acc | Some pre -> let s = Seq.fold_left (fun acc (s, _) -> s :: acc) [] bindings in pre path s acc in let post path bindings acc = match post with - | None -> Lwt.return acc + | None -> acc | Some post -> let s = Seq.fold_left (fun acc (s, _) -> s :: acc) [] bindings in post path s acc in let rec aux : type r. (t, acc, r) cps_folder = fun ~path acc d t k -> - let apply acc = node path t acc >>= tree path (`Node t) in + let apply acc = node path t acc |> tree path (`Node t) in let next acc = match force with | `True -> ( match order with | `Random state -> - let* m = to_map ~cache t >|= get_ok "fold" in + let m = to_map ~cache t |> get_ok "fold" in let arr = StepMap.to_array m in let () = shuffle state arr in let s = Array.to_seq arr in (seq [@tailcall]) ~path acc d s k | `Sorted -> - let* m = to_map ~cache t >|= get_ok "fold" in + let m = to_map ~cache t |> get_ok "fold" in (map [@tailcall]) ~path acc d (Some m) k | `Undefined -> ( match @@ -1384,7 +1382,7 @@ module Make (P : Backend.S) = struct | Repo_value (repo, v) -> (value [@tailcall]) ~path acc d (repo, v, None) k | Repo_key (repo, _key) -> - let* v = to_value ~cache t >|= get_ok "fold" in + let v = to_value ~cache t |> get_ok "fold" in (value [@tailcall]) ~path acc d (repo, v, None) k | Value_dirty (repo, v, um) -> (value [@tailcall]) ~path acc d (repo, v, Some um) k @@ -1405,18 +1403,18 @@ module Make (P : Backend.S) = struct (seq [@tailcall]) ~path acc d s k) | None -> (* XXX: That node is skipped if is is of tag Value *) - skip path acc >>= k) + skip path acc |> k) in match depth with - | None -> apply acc >>= next - | Some (`Eq depth) -> if d < depth then next acc else apply acc >>= k + | None -> apply acc |> next + | Some (`Eq depth) -> if d < depth then next acc else apply acc |> k | Some (`Le depth) -> - if d < depth then apply acc >>= next else apply acc >>= k + if d < depth then apply acc |> next else apply acc |> k | Some (`Lt depth) -> - if d < depth - 1 then apply acc >>= next else apply acc >>= k - | Some (`Ge depth) -> if d < depth then next acc else apply acc >>= next + if d < depth - 1 then apply acc |> next else apply acc |> k + | Some (`Ge depth) -> if d < depth then next acc else apply acc |> next | Some (`Gt depth) -> - if d <= depth then next acc else apply acc >>= next + if d <= depth then next acc else apply acc |> next and aux_uniq : type r. (t, acc, r) cps_folder = fun ~path acc d t k -> if uniq = `False then (aux [@tailcall]) ~path acc d t k @@ -1433,7 +1431,7 @@ module Make (P : Backend.S) = struct | `Contents c -> ( let apply () = let tree path = tree path (`Contents c) in - Contents.fold ~force ~cache ~path contents tree (fst c) acc >>= k + Contents.fold ~force ~cache ~path contents tree (fst c) acc |> k in match depth with | None -> apply () @@ -1476,11 +1474,11 @@ module Make (P : Backend.S) = struct seq ~path acc d bindings k and seq : type r. ((step * elt) Seq.t, acc, r) cps_folder = fun ~path acc d bindings k -> - let* acc = pre path bindings acc in + let acc = pre path bindings acc in (steps [@tailcall]) ~path acc d bindings (fun acc -> - post path bindings acc >>= k) + post path bindings acc |> k) in - aux_uniq ~path acc 0 t Lwt.return + aux_uniq ~path acc 0 t Fun.id let incremental_length t step up n updates = match t.info.length with @@ -1544,14 +1542,14 @@ module Make (P : Backend.S) = struct | `pruned ] Scan.t) with - | Map m -> Lwt.return (of_map m) - | Repo_value (repo, v) -> Lwt.return (of_value repo v StepMap.empty) + | Map m -> of_map m + | Repo_value (repo, v) -> of_value repo v StepMap.empty | Repo_key (repo, k) -> - let+ v = value_of_key ~cache:true t repo k >|= get_ok "update" in + let v = value_of_key ~cache:true t repo k |> get_ok "update" in of_value repo v StepMap.empty - | Value_dirty (repo, v, um) -> Lwt.return (of_value repo v um) - | Portable p -> Lwt.return (of_portable p StepMap.empty) - | Portable_dirty (p, um) -> Lwt.return (of_portable p um) + | Value_dirty (repo, v, um) -> of_value repo v um + | Portable p -> of_portable p StepMap.empty + | Portable_dirty (p, um) -> of_portable p um | Pruned h -> pruned_hash_exn "update" h let remove t step = update t step Remove @@ -1580,19 +1578,19 @@ module Make (P : Backend.S) = struct let f ~old x y = let old = Merge.bind_promise old (fun old () -> - let+ m = to_map ~cache:true old >|= Option.of_result in + let m = to_map ~cache:true old |> Option.of_result in Ok (Some m)) in match merge_env x.info.env y.info.env with - | Error _ as e -> Lwt.return e + | Error _ as e -> e | Ok env -> ( - let* x = to_map ~cache:true x >|= Option.of_result in - let* y = to_map ~cache:true y >|= Option.of_result in + let x = to_map ~cache:true x |> Option.of_result in + let y = to_map ~cache:true y |> Option.of_result in let m = StepMap.merge elt_t (fun _step -> (merge_elt [@tailcall]) Merge.option) in - Merge.(f @@ option m) ~old x y >|= function + Merge.(f @@ option m) ~old x y |> function | Ok (Some map) -> Ok (of_map ~env map) | Ok None -> Error (`Conflict "empty map") | Error _ as e -> e) @@ -1651,10 +1649,10 @@ module Make (P : Backend.S) = struct [@@deriving irmin] let to_backend_node n = - Node.to_value ~cache:true n >|= get_ok "to_backend_node" + Node.to_value ~cache:true n |> get_ok "to_backend_node" let to_backend_portable_node n = - Node.to_portable_value ~cache:true n >|= get_ok "to_backend_portable_node" + Node.to_portable_value ~cache:true n |> get_ok "to_backend_portable_node" let of_backend_node repo n = let env = Env.empty () in @@ -1712,27 +1710,25 @@ module Make (P : Backend.S) = struct let sub ~cache ctx t path = let rec aux node path = match Path.decons path with - | None -> Lwt.return_some node + | None -> Some node | Some (h, p) -> ( - Node.findv ~cache ctx node h >>= function - | None | Some (`Contents _) -> Lwt.return_none + Node.findv ~cache ctx node h |> function + | None | Some (`Contents _) -> None | Some (`Node n) -> (aux [@tailcall]) n p) in - match t with - | `Node n -> (aux [@tailcall]) n path - | `Contents _ -> Lwt.return_none + match t with `Node n -> (aux [@tailcall]) n path | `Contents _ -> None let find_tree (t : t) path = let cache = true in [%log.debug "Tree.find_tree %a" pp_path path]; match (t, Path.rdecons path) with - | v, None -> Lwt.return_some v + | v, None -> Some v | _, Some (path, file) -> ( - sub ~cache "find_tree.sub" t path >>= function - | None -> Lwt.return_none + sub ~cache "find_tree.sub" t path |> function + | None -> None | Some n -> Node.findv ~cache "find_tree.findv" n file) - let id _ _ acc = Lwt.return acc + let id _ _ acc = acc let fold ?(order = `Sorted) ?(force = `True) ?(cache = false) ?(uniq = `False) ?pre ?post ?depth ?(contents = id) ?(node = id) ?(tree = id) (t : t) acc = @@ -1771,58 +1767,55 @@ module Make (P : Backend.S) = struct Fmt.kstr invalid_arg "Irmin.Tree.%s: %a not found" n pp_path k let get_tree (t : t) path = - find_tree t path >|= function + find_tree t path |> function | None -> err_not_found "get_tree" path | Some v -> v let find_all t k = - find_tree t k >>= function - | None | Some (`Node _) -> Lwt.return_none + find_tree t k |> function + | None | Some (`Node _) -> None | Some (`Contents (c, m)) -> - let+ c = Contents.to_value ~cache:true c in + let c = Contents.to_value ~cache:true c in Some (get_ok "find_all" c, m) - let find t k = - find_all t k >|= function None -> None | Some (c, _) -> Some c + let find t k = find_all t k |> function None -> None | Some (c, _) -> Some c let get_all t k = - find_all t k >>= function - | None -> err_not_found "get" k - | Some v -> Lwt.return v + find_all t k |> function None -> err_not_found "get" k | Some v -> v - let get t k = get_all t k >|= fun (c, _) -> c - let mem t k = find t k >|= function None -> false | _ -> true - let mem_tree t k = find_tree t k >|= function None -> false | _ -> true + let get t k = get_all t k |> fun (c, _) -> c + let mem t k = find t k |> function None -> false | _ -> true + let mem_tree t k = find_tree t k |> function None -> false | _ -> true let kind t path = let cache = true in [%log.debug "Tree.kind %a" pp_path path]; match (t, Path.rdecons path) with - | `Contents _, None -> Lwt.return_some `Contents - | `Node _, None -> Lwt.return_some `Node + | `Contents _, None -> Some `Contents + | `Node _, None -> Some `Node | _, Some (dir, file) -> ( - sub ~cache "kind.sub" t dir >>= function - | None -> Lwt.return_none + sub ~cache "kind.sub" t dir |> function + | None -> None | Some m -> ( - Node.findv ~cache "kind.findv" m file >>= function - | None -> Lwt.return_none - | Some (`Contents _) -> Lwt.return_some `Contents - | Some (`Node _) -> Lwt.return_some `Node)) + Node.findv ~cache "kind.findv" m file |> function + | None -> None + | Some (`Contents _) -> Some `Contents + | Some (`Node _) -> Some `Node)) let length t ?(cache = true) path = [%log.debug "Tree.length %a" pp_path path]; - sub ~cache "length" t path >>= function - | None -> Lwt.return 0 + sub ~cache "length" t path |> function + | None -> 0 | Some n -> Node.length ~cache:true n let seq t ?offset ?length ?(cache = true) path = [%log.debug "Tree.seq %a" pp_path path]; - sub ~cache "seq.sub" t path >>= function - | None -> Lwt.return Seq.empty - | Some n -> Node.seq ?offset ?length ~cache n >|= get_ok "seq" + sub ~cache "seq.sub" t path |> function + | None -> Seq.empty + | Some n -> Node.seq ?offset ?length ~cache n |> get_ok "seq" let list t ?offset ?length ?(cache = true) path = - seq t ?offset ?length ~cache path >|= List.of_seq + seq t ?offset ?length ~cache path |> List.of_seq let empty () = `Node (Node.empty ()) @@ -1863,31 +1856,31 @@ module Make (P : Backend.S) = struct | true -> root_tree | false -> `Node (Node.empty ()) in - f (Some root_tree) >>= function + match f (Some root_tree) with (* Here we consider "deleting" a root contents value or node to consist of changing it to an empty node. Note that this introduces sensitivity to ordering of subtree operations: updating in a subtree and adding the subtree are not necessarily commutative. *) - | None -> Lwt.return empty_tree + | None -> empty_tree | Some (`Node _ as new_root) -> ( match maybe_equal root_tree new_root with - | True -> Lwt.return root_tree - | Maybe | False -> Lwt.return new_root) + | True -> root_tree + | Maybe | False -> new_root) | Some (`Contents c' as new_root) -> ( match root_tree with - | `Contents c when contents_equal c c' -> Lwt.return root_tree - | _ -> Lwt.return new_root)) + | `Contents c when contents_equal c c' -> root_tree + | _ -> new_root)) | Some (path, file) -> ( let rec aux : type r. path -> node -> (node updated, r) cont_lwt = fun path parent_node k -> let changed n = k (Changed n) in match Path.decons path with | None -> ( - let with_new_child t = Node.add parent_node file t >>= changed in - let* old_binding = + let with_new_child t = Node.add parent_node file t |> changed in + let old_binding = Node.findv ~cache "update_tree.findv" parent_node file in - let* new_binding = f old_binding in + let new_binding = f old_binding in match (old_binding, new_binding) with | None, None -> k Unchanged | None, Some (`Contents _ as t) -> with_new_child t @@ -1895,10 +1888,10 @@ module Make (P : Backend.S) = struct match prune_empty n with | true -> k Unchanged | false -> with_new_child t) - | Some _, None -> Node.remove parent_node file >>= changed + | Some _, None -> Node.remove parent_node file |> changed | Some old_value, Some (`Node n as t) -> ( match prune_empty n with - | true -> Node.remove parent_node file >>= changed + | true -> Node.remove parent_node file |> changed | false -> ( match maybe_equal old_value t with | True -> k Unchanged @@ -1909,7 +1902,7 @@ module Make (P : Backend.S) = struct | false -> with_new_child t) | Some (`Node _), Some (`Contents _ as t) -> with_new_child t) | Some (step, key_suffix) -> - let* old_binding = + let old_binding = Node.findv ~cache "update_tree.findv" parent_node step in let to_recurse = @@ -1927,28 +1920,28 @@ module Make (P : Backend.S) = struct | true -> (* A [remove] has emptied previously non-empty child with binding [h], so we remove the binding. *) - Node.remove parent_node step >>= changed + Node.remove parent_node step |> changed | false -> - Node.add parent_node step (`Node child) >>= changed)) + Node.add parent_node step (`Node child) |> changed)) in let top_node = match root_tree with `Node n -> n | `Contents _ -> Node.empty () in aux path top_node @@ function - | Unchanged -> Lwt.return root_tree + | Unchanged -> root_tree | Changed node -> Env.copy ~into:node.info.env (get_env root_tree); - Lwt.return (`Node node)) + `Node node) let update t k ?(metadata = Metadata.default) f = let cache = true in [%log.debug "Tree.update %a" pp_path k]; update_tree ~cache t k ~f_might_return_empty_node:false ~f:(fun t -> - let+ old_contents = + let old_contents = match t with - | Some (`Node _) | None -> Lwt.return_none + | Some (`Node _) | None -> None | Some (`Contents (c, _)) -> - let+ c = Contents.to_value ~cache c in + let c = Contents.to_value ~cache c in Some (get_ok "update" c) in match f old_contents with @@ -1958,36 +1951,36 @@ module Make (P : Backend.S) = struct let add t k ?(metadata = Metadata.default) c = [%log.debug "Tree.add %a" pp_path k]; update_tree ~cache:true t k - ~f:(fun _ -> Lwt.return_some (of_contents ~metadata c)) + ~f:(fun _ -> Some (of_contents ~metadata c)) ~f_might_return_empty_node:false let add_tree t k v = [%log.debug "Tree.add_tree %a" pp_path k]; update_tree ~cache:true t k - ~f:(fun _ -> Lwt.return_some v) + ~f:(fun _ -> Some v) ~f_might_return_empty_node:true let remove t k = [%log.debug "Tree.remove %a" pp_path k]; update_tree ~cache:true t k - ~f:(fun _ -> Lwt.return_none) + ~f:(fun _ -> None) ~f_might_return_empty_node:false let update_tree t k f = [%log.debug "Tree.update_tree %a" pp_path k]; - update_tree ~cache:true t k ~f:(Lwt.wrap1 f) ~f_might_return_empty_node:true + update_tree ~cache:true t k ~f ~f_might_return_empty_node:true let import repo = function | `Contents (k, m) -> ( cnt.contents_mem <- cnt.contents_mem + 1; - P.Contents.mem (P.Repo.contents_t repo) k >|= function + P.Contents.mem (P.Repo.contents_t repo) k |> function | true -> let env = Env.empty () in Some (`Contents (Contents.of_key ~env repo k, m)) | false -> None) | `Node k -> ( cnt.node_mem <- cnt.node_mem + 1; - P.Node.mem (P.Repo.node_t repo) k >|= function + P.Node.mem (P.Repo.node_t repo) k |> function | true -> let env = Env.empty () in Some (`Node (Node.of_key ~env repo k)) @@ -2022,7 +2015,7 @@ module Make (P : Backend.S) = struct let add_node n v k = cnt.node_add <- cnt.node_add + 1; - let* key = P.Node.add node_t v in + let key = P.Node.add node_t v in let () = (* Sanity check: Did we just store the same hash as the one represented by the Tree.Node [n]? *) @@ -2146,7 +2139,7 @@ module Make (P : Backend.S) = struct k key else ( cnt.node_mem <- cnt.node_mem + 1; - let* mem = P.Node.mem node_t key in + let mem = P.Node.mem node_t key in if not mem then (* Case 6. [n] contains a key that is not known by [repo]. Let's abort. *) @@ -2155,14 +2148,14 @@ module Make (P : Backend.S) = struct (* Case 7. [n] contains a key that is known by the [repo]. *) k key) | None -> ( - let* skip_when_some = + let skip_when_some = match Node.cached_hash n with | None -> (* No pre-computed hash. *) - Lwt.return_none + None | Some h -> ( cnt.node_index <- cnt.node_index + 1; - P.Node.index node_t h >>= function + P.Node.index node_t h |> function | None -> (* Pre-computed hash is unknown by repo. @@ -2170,10 +2163,10 @@ module Make (P : Backend.S) = struct in the store, but it's not indexed. If so, we're adding a duplicate here – this isn't an issue for correctness, but does waste space. *) - Lwt.return_none + None | Some key -> cnt.node_mem <- cnt.node_mem + 1; - let+ mem = P.Node.mem node_t key in + let mem = P.Node.mem node_t key in if mem then (* Case 8. The pre-computed hash is converted into a key *) @@ -2225,10 +2218,10 @@ module Make (P : Backend.S) = struct Contents.export ?clear repo c key; k `Content_exported | Contents.Value _ -> - let* v = Contents.to_value ~cache c in + let v = Contents.to_value ~cache c in let v = get_ok "export" v in cnt.contents_add <- cnt.contents_add + 1; - let* key = P.Contents.add contents_t v in + let key = P.Contents.add contents_t v in let () = let h = P.Contents.Key.to_hash key in let h' = Contents.hash ~cache c in @@ -2255,21 +2248,21 @@ module Make (P : Backend.S) = struct | Seq.Cons ((`Contents _ as c), rest) -> on_contents c (fun `Content_exported -> on_node_seq rest k) in - on_node (`Node n) (fun key -> Lwt.return key) + on_node (`Node n) (fun key -> key) let merge : t Merge.t = let f ~old (x : t) y = - Merge.(f Node.merge_elt) ~old x y >>= function + Merge.(f Node.merge_elt) ~old x y |> function | Ok t -> Merge.ok t - | Error e -> Lwt.return (Error e) + | Error e -> Error e in Merge.v t f let entries path tree = let rec aux acc = function - | [] -> Lwt.return acc + | [] -> acc | (path, h) :: todo -> - let* childs = Node.bindings ~cache:true h >|= get_ok "entries" in + let childs = Node.bindings ~cache:true h |> get_ok "entries" in let acc, todo = List.fold_left (fun (acc, todo) (k, v) -> @@ -2297,81 +2290,79 @@ module Make (P : Backend.S) = struct | Error _, Error _ -> assert false let diff_contents x y = - if Node.contents_equal x y then Lwt.return_nil + if Node.contents_equal x y then [] else - let* cx = Contents.to_value ~cache:true (fst x) in - let+ cy = Contents.to_value ~cache:true (fst y) in + let cx = Contents.to_value ~cache:true (fst x) in + let cy = Contents.to_value ~cache:true (fst y) in diff_force_result cx cy ~empty:[] ~diff_ok:(fun (cx, cy) -> [ `Updated ((cx, snd x), (cy, snd y)) ]) let diff_node (x : node) (y : node) = let bindings n = - Node.to_map ~cache:true n >|= function + Node.to_map ~cache:true n |> function | Ok m -> Ok (StepMap.bindings m) | Error _ as e -> e in let removed acc (k, (c, m)) = - let+ c = Contents.to_value ~cache:true c >|= get_ok "diff_node" in + let c = Contents.to_value ~cache:true c |> get_ok "diff_node" in (k, `Removed (c, m)) :: acc in let added acc (k, (c, m)) = - let+ c = Contents.to_value ~cache:true c >|= get_ok "diff_node" in + let c = Contents.to_value ~cache:true c |> get_ok "diff_node" in (k, `Added (c, m)) :: acc in let rec diff_bindings acc todo path x y = let acc = ref acc in let todo = ref todo in - let* () = + let () = alist_iter2_lwt compare_step - (fun key v -> + (fun key v () -> let path = Path.rcons path key in match v with (* Left *) | `Left (`Contents x) -> - let+ x = removed !acc (path, x) in + let x = removed !acc (path, x) in acc := x | `Left (`Node x) -> - let* xs = entries path x in - let+ xs = Lwt_list.fold_left_s removed !acc xs in + let xs = entries path x in + let xs = List.fold_left removed !acc xs in acc := xs (* Right *) | `Right (`Contents y) -> - let+ y = added !acc (path, y) in + let y = added !acc (path, y) in acc := y | `Right (`Node y) -> - let* ys = entries path y in - let+ ys = Lwt_list.fold_left_s added !acc ys in + let ys = entries path y in + let ys = List.fold_left added !acc ys in acc := ys (* Both *) - | `Both (`Node x, `Node y) -> - todo := (path, x, y) :: !todo; - Lwt.return_unit + | `Both (`Node x, `Node y) -> todo := (path, x, y) :: !todo | `Both (`Contents x, `Node y) -> - let* ys = entries path y in - let* x = removed !acc (path, x) in - let+ ys = Lwt_list.fold_left_s added x ys in + let ys = entries path y in + let x = removed !acc (path, x) in + let ys = List.fold_left added x ys in acc := ys | `Both (`Node x, `Contents y) -> - let* xs = entries path x in - let* y = added !acc (path, y) in - let+ ys = Lwt_list.fold_left_s removed y xs in + let xs = entries path x in + let y = added !acc (path, y) in + let ys = List.fold_left removed y xs in acc := ys | `Both (`Contents x, `Contents y) -> - let+ content_diffs = - diff_contents x y >|= List.map (fun d -> (path, d)) + let content_diffs = + diff_contents x y |> List.map (fun d -> (path, d)) in acc := content_diffs @ !acc) x y in (diff_node [@tailcall]) !acc !todo and diff_node acc = function - | [] -> Lwt.return acc + | [] -> acc | (path, x, y) :: todo -> if Node.equal x y then (diff_node [@tailcall]) acc todo else - let* x = bindings x in - let* y = bindings y in - diff_force_result ~empty:Lwt.return_nil + let x = bindings x in + let y = bindings y in + diff_force_result ~empty:[] ~diff_ok:(fun (x, y) -> diff_bindings acc todo path x y) x y in @@ -2380,19 +2371,19 @@ module Make (P : Backend.S) = struct let diff (x : t) (y : t) = match (x, y) with | `Contents ((c1, m1) as x), `Contents ((c2, m2) as y) -> - if contents_equal x y then Lwt.return_nil + if contents_equal x y then [] else - let* c1 = Contents.to_value ~cache:true c1 >|= get_ok "diff" in - let* c2 = Contents.to_value ~cache:true c2 >|= get_ok "diff" in - Lwt.return [ (Path.empty, `Updated ((c1, m1), (c2, m2))) ] + let c1 = Contents.to_value ~cache:true c1 |> get_ok "diff" in + let c2 = Contents.to_value ~cache:true c2 |> get_ok "diff" in + [ (Path.empty, `Updated ((c1, m1), (c2, m2))) ] | `Node x, `Node y -> diff_node x y | `Contents (x, m), `Node y -> - let* diff = diff_node (Node.empty ()) y in - let+ x = Contents.to_value ~cache:true x >|= get_ok "diff" in + let diff = diff_node (Node.empty ()) y in + let x = Contents.to_value ~cache:true x |> get_ok "diff" in (Path.empty, `Removed (x, m)) :: diff | `Node x, `Contents (y, m) -> - let* diff = diff_node x (Node.empty ()) in - let+ y = Contents.to_value ~cache:true y >|= get_ok "diff" in + let diff = diff_node x (Node.empty ()) in + let y = Contents.to_value ~cache:true y |> get_ok "diff" in (Path.empty, `Added (y, m)) :: diff type concrete = @@ -2445,14 +2436,14 @@ module Make (P : Backend.S) = struct match t with | `Contents c -> contents c k | `Node n -> - let* m = Node.to_map ~cache:true n in + let m = Node.to_map ~cache:true n in let bindings = m |> get_ok "to_concrete" |> StepMap.bindings in (node [@tailcall]) [] bindings (fun n -> let n = List.sort (fun (s, _) (s', _) -> compare_step s s') n in k (`Tree n)) and contents : type r. Contents.t * metadata -> (concrete, r) cont_lwt = fun (c, m) k -> - let* c = Contents.to_value ~cache:true c >|= get_ok "to_concrete" in + let c = Contents.to_value ~cache:true c |> get_ok "to_concrete" in k (`Contents (c, m)) and node : type r. @@ -2470,7 +2461,7 @@ module Make (P : Backend.S) = struct (contents [@tailcall]) c (fun c -> (node [@tailcall]) ((s, c) :: childs) t k)) in - tree t (fun x -> Lwt.return x) + tree t (fun x -> x) let key (t : t) = [%log.debug "Tree.key"]; @@ -2491,15 +2482,13 @@ module Make (P : Backend.S) = struct let stats ?(force = false) (t : t) = let cache = true in let force = - if force then `True - else `False (fun k s -> set_depth k s |> incr_skips |> Lwt.return) + if force then `True else `False (fun k s -> set_depth k s |> incr_skips) in - let contents k _ s = set_depth k s |> incr_leafs |> Lwt.return in + let contents k _ s = set_depth k s |> incr_leafs in let pre k childs s = - if childs = [] then Lwt.return s - else set_depth k s |> set_width childs |> incr_nodes |> Lwt.return + if childs = [] then s else set_depth k s |> set_width childs |> incr_nodes in - let post _ _ acc = Lwt.return acc in + let post _ _ acc = acc in fold ~force ~cache ~pre ~post ~contents t empty_stats let counters () = cnt @@ -2556,8 +2545,7 @@ module Make (P : Backend.S) = struct let h = P.Node.Key.to_hash k in err_dangling_hash h in - Node.to_portable_value_aux ~cache:false ~value_of_key ~return:Fun.id - ~bind:(fun x f -> f x) + Node.to_portable_value_aux ~cache:false ~value_of_key in match to_portable_value node with | Error (`Dangling_hash h) -> k (Blinded_node h) @@ -2629,7 +2617,7 @@ module Make (P : Backend.S) = struct let h = P.Node.Key.to_hash k in err_dangling_hash h in - Node.findv_aux ~value_of_key ~return:Fun.id ~bind:(fun x f -> f x) + Node.findv_aux ~value_of_key in fun node steps k -> let rec aux acc = function @@ -2767,7 +2755,7 @@ module Make (P : Backend.S) = struct let produce_proof repo kinded_key f = Env.with_produce @@ fun env ~start_serialise -> let tree = import_with_env ~env repo kinded_key in - let+ tree_after, result = f tree in + let tree_after, result = f tree in let after = hash tree_after in (* Here, we build a proof from [tree] (not from [tree_after]!), on purpose: we look at the effect on [f] on [tree]'s caches and we rely on the fact @@ -2790,36 +2778,33 @@ module Make (P : Backend.S) = struct if not (equal_kinded_hash before h) then Irmin_proof.bad_proof_exn "verify_proof: invalid before hash"; let tree = pruned_with_env ~env h in - Lwt.catch - (fun () -> - stop_deserialise (); - (* Then apply [f] on a cleaned tree, an exception will be raised if [f] - reads out of the proof. *) - let+ tree_after, result = f tree in - (* then check that [after] corresponds to [tree_after]'s hash. *) - if not (equal_kinded_hash after (hash tree_after)) then - Irmin_proof.bad_proof_exn "verify_proof: invalid after hash"; - (tree_after, result)) - (function - | Pruned_hash h -> - (* finaly check that [f] only access valid parts of the proof. *) - Fmt.kstr Irmin_proof.bad_proof_exn - "verify_proof: %s is trying to read through a blinded node or \ - object (%a)" - h.context pp_hash h.hash - | e -> raise e) + try + stop_deserialise (); + (* Then apply [f] on a cleaned tree, an exception will be raised if [f] + reads out of the proof. *) + let tree_after, result = f tree in + (* then check that [after] corresponds to [tree_after]'s hash. *) + if not (equal_kinded_hash after (hash tree_after)) then + Irmin_proof.bad_proof_exn "verify_proof: invalid after hash"; + (tree_after, result) + with + | Pruned_hash h -> + (* finaly check that [f] only access valid parts of the proof. *) + Fmt.kstr Irmin_proof.bad_proof_exn + "verify_proof: %s is trying to read through a blinded node or object \ + (%a)" + h.context pp_hash h.hash + | e -> raise e type verifier_error = [ `Proof_mismatch of string ] [@@deriving irmin] let verify_proof p f = - Lwt.catch - (fun () -> - let+ r = verify_proof_exn p f in - Ok r) - (function - | Irmin_proof.Bad_proof e -> - Lwt.return (Error (`Proof_mismatch e.context)) - | e -> Lwt.fail e) + try + let r = verify_proof_exn p f in + Ok r + with + | Irmin_proof.Bad_proof e -> Error (`Proof_mismatch e.context) + | e -> raise e let hash_of_proof_state state = let env = Env.empty () in diff --git a/src/irmin/tree_intf.ml b/src/irmin/tree_intf.ml index 844d07226e..85c45c1e91 100644 --- a/src/irmin/tree_intf.ml +++ b/src/irmin/tree_intf.ml @@ -74,7 +74,7 @@ module type S = sig {!Pruned_hash} exception. Attempting to export a tree containing pruned sub-trees to a repository will fail similarly. *) - val kind : t -> path -> [ `Contents | `Node ] option Lwt.t + val kind : t -> path -> [ `Contents | `Node ] option (** [kind t k] is the type of [s] in [t]. It could either be a tree node or some file contents. It is [None] if [k] is not present in [t]. *) @@ -84,7 +84,7 @@ module type S = sig (** {1 Diffs} *) - val diff : t -> t -> (path * (contents * metadata) Diff.t) list Lwt.t + val diff : t -> t -> (path * (contents * metadata) Diff.t) list (** [diff x y] is the difference of contents between [x] and [y]. *) (** {1 Manipulating Contents} *) @@ -120,11 +120,11 @@ module type S = sig (** [key t] is the key of the {!contents} value returned when [t] is {!val-force}d successfully. *) - val force : t -> contents or_error Lwt.t + val force : t -> contents or_error (** [force t] forces evaluation of the lazy content value [t], or returns an error if no such value exists in the underlying repository. *) - val force_exn : t -> contents Lwt.t + val force_exn : t -> contents (** Equivalent to {!val-force}, but raises an exception if the lazy content value is not present in the underlying repository. *) @@ -143,14 +143,14 @@ module type S = sig storing of new data, it doesn't discard the existing one. *) end - val mem : t -> path -> bool Lwt.t + val mem : t -> path -> bool (** [mem t k] is true iff [k] is associated to some contents in [t]. *) - val find_all : t -> path -> (contents * metadata) option Lwt.t + val find_all : t -> path -> (contents * metadata) option (** [find_all t k] is [Some (b, m)] if [k] is associated to the contents [b] and metadata [m] in [t] and [None] if [k] is not present in [t]. *) - val length : t -> ?cache:bool -> path -> int Lwt.t + val length : t -> ?cache:bool -> path -> int (** [length t key] is the number of files and sub-nodes stored under [key] in [t]. @@ -160,19 +160,14 @@ module type S = sig [cache] defaults to [true], see {!caching} for an explanation of the parameter.*) - val find : t -> path -> contents option Lwt.t + val find : t -> path -> contents option (** [find] is similar to {!find_all} but it discards metadata. *) - val get_all : t -> path -> (contents * metadata) Lwt.t + val get_all : t -> path -> contents * metadata (** Same as {!find_all} but raise [Invalid_arg] if [k] is not present in [t]. *) val list : - t -> - ?offset:int -> - ?length:int -> - ?cache:bool -> - path -> - (step * t) list Lwt.t + t -> ?offset:int -> ?length:int -> ?cache:bool -> path -> (step * t) list (** [list t key] is the list of files and sub-nodes stored under [k] in [t]. The result order is not specified but is stable. @@ -187,52 +182,48 @@ module type S = sig ?length:int -> ?cache:bool -> path -> - (step * t) Seq.t Lwt.t + (step * t) Seq.t (** [seq t key] follows the same behavior as {!list} but returns a sequence. *) - val get : t -> path -> contents Lwt.t + val get : t -> path -> contents (** Same as {!get_all} but ignore the metadata. *) - val add : t -> path -> ?metadata:metadata -> contents -> t Lwt.t + val add : t -> path -> ?metadata:metadata -> contents -> t (** [add t k c] is the tree where the key [k] is bound to the contents [c] but is similar to [t] for other bindings. *) val update : - t -> - path -> - ?metadata:metadata -> - (contents option -> contents option) -> - t Lwt.t + t -> path -> ?metadata:metadata -> (contents option -> contents option) -> t (** [update t k f] is the tree [t'] that is the same as [t] for all keys except [k], and whose binding for [k] is determined by [f (find t k)]. If [k] refers to an internal node of [t], [f] is called with [None] to determine the value with which to replace it. *) - val remove : t -> path -> t Lwt.t + val remove : t -> path -> t (** [remove t k] is the tree where [k] bindings has been removed but is similar to [t] for other bindings. *) (** {1 Manipulating Subtrees} *) - val mem_tree : t -> path -> bool Lwt.t + val mem_tree : t -> path -> bool (** [mem_tree t k] is false iff [find_tree k = None]. *) - val find_tree : t -> path -> t option Lwt.t + val find_tree : t -> path -> t option (** [find_tree t k] is [Some v] if [k] is associated to [v] in [t]. It is [None] if [k] is not present in [t]. *) - val get_tree : t -> path -> t Lwt.t + val get_tree : t -> path -> t (** [get_tree t k] is [v] if [k] is associated to [v] in [t]. Raise [Invalid_arg] if [k] is not present in [t].*) - val add_tree : t -> path -> t -> t Lwt.t + val add_tree : t -> path -> t -> t (** [add_tree t k v] is the tree where the key [k] is bound to the non-empty tree [v] but is similar to [t] for other bindings. If [v] is empty, this is equivalent to [remove t k]. *) - val update_tree : t -> path -> (t option -> t option) -> t Lwt.t + val update_tree : t -> path -> (t option -> t option) -> t (** [update_tree t k f] is the tree [t'] that is the same as [t] for all subtrees except under [k], and whose subtree at [k] is determined by [f (find_tree t k)]. @@ -254,7 +245,7 @@ module type S = sig val empty_marks : unit -> marks (** [empty_marks ()] is an empty collection of marks. *) - type 'a force = [ `True | `False of path -> 'a -> 'a Lwt.t ] + type 'a force = [ `True | `False of path -> 'a -> 'a ] (** The type for {!fold}'s [force] parameter. [`True] forces the fold to read the objects of the lazy nodes and contents. [`False f] is applying [f] on every lazy node and content value instead. *) @@ -265,7 +256,7 @@ module type S = sig collection of marks [m] to store the cache of keys: the fold will modify [m]. This can be used for incremental folds. *) - type ('a, 'b) folder = path -> 'b -> 'a -> 'a Lwt.t + type ('a, 'b) folder = path -> 'b -> 'a -> 'a (** The type for {!fold}'s folders: [pre], [post], [contents], [node], and [tree], where ['a] is the accumulator and ['b] is the item folded. *) @@ -292,7 +283,7 @@ module type S = sig ?tree:('a, t) folder -> t -> 'a -> - 'a Lwt.t + 'a (** [fold t acc] folds over [t]'s nodes with node-specific folders: [contents], [node], and [tree], based on a node's {!kind}. @@ -339,7 +330,7 @@ module type S = sig [@@deriving irmin] (** The type for tree stats. *) - val stats : ?force:bool -> t -> stats Lwt.t + val stats : ?force:bool -> t -> stats (** [stats ~force t] are [t]'s statistics. If [force] is true, this will force the reading of lazy nodes. By default it is [false]. *) @@ -356,7 +347,7 @@ module type S = sig @raise Invalid_argument if [c] contains duplicate bindings for a given path. *) - val to_concrete : t -> concrete Lwt.t + val to_concrete : t -> concrete (** [to_concrete t] is the concrete tree equivalent of the subtree [t]. *) (** {1 Proofs} *) @@ -455,7 +446,7 @@ module type Sigs = sig [ `Contents of B.Contents.Key.t * metadata | `Node of B.Node.Key.t ] [@@deriving irmin] - val import : B.Repo.t -> kinded_key -> t option Lwt.t + val import : B.Repo.t -> kinded_key -> t option val import_no_check : B.Repo.t -> kinded_key -> t val export : @@ -464,28 +455,28 @@ module type Sigs = sig [> write ] B.Contents.t -> [> read_write ] B.Node.t -> node -> - B.Node.key Lwt.t + B.Node.key val dump : t Fmt.t val equal : t -> t -> bool val key : t -> kinded_key option val hash : ?cache:bool -> t -> kinded_hash - val to_backend_node : node -> B.Node.Val.t Lwt.t - val to_backend_portable_node : node -> B.Node_portable.t Lwt.t + val to_backend_node : node -> B.Node.Val.t + val to_backend_portable_node : node -> B.Node_portable.t val of_backend_node : B.Repo.t -> B.Node.value -> node type 'result producer := B.Repo.t -> kinded_key -> - (t -> (t * 'result) Lwt.t) -> - (Proof.t * 'result) Lwt.t + (t -> (t * 'result)) -> + (Proof.t * 'result) type verifier_error = [ `Proof_mismatch of string ] [@@deriving irmin] type 'result verifier := Proof.t -> - (t -> (t * 'result) Lwt.t) -> - (t * 'result, verifier_error) result Lwt.t + (t -> (t * 'result)) -> + (t * 'result, verifier_error) result val produce_proof : 'a producer val verify_proof : 'a verifier diff --git a/src/irmin/watch.ml b/src/irmin/watch.ml index 55723d184f..5abfc4eed4 100644 --- a/src/irmin/watch.ml +++ b/src/irmin/watch.ml @@ -27,8 +27,7 @@ let none _ _ = let listen_dir_hook = ref none -type hook = - int -> string -> (string -> unit Lwt.t) -> (unit -> unit Lwt.t) Lwt.t +type hook = int -> string -> (string -> unit) -> unit -> unit let set_listen_dir_hook (h : hook) = listen_dir_hook := h @@ -42,6 +41,11 @@ let global = id () let workers_r = ref 0 let workers () = !workers_r +(* Not sure this is right *) +let rec stream_iter f s = + (match Eio.Stream.take s with Some v -> f v | None -> ()); + stream_iter f s + let scheduler () = let p = ref None in let niet () = () in @@ -50,12 +54,17 @@ let scheduler () = match !p with | Some p -> p elt | None -> - let stream, push = Lwt_stream.create () in + let stream, push = + let s = Eio.Stream.create max_int in + (s, Eio.Stream.add s) + in incr workers_r; - Lwt.async (fun () -> + ( Eio.Switch.run @@ fun sw -> + Eio.Fiber.fork ~sw @@ fun () -> stream_iter (fun f -> f ()) stream ); + (* Lwt.async (fun () -> (* FIXME: we would like to skip some updates if more recent ones are at the back of the queue. *) - Lwt_stream.iter_s (fun f -> f ()) stream); + Eio.Stream.take (fun f -> f ()) stream); *) p := Some push; (c := fun () -> push None); push elt @@ -95,8 +104,8 @@ struct let compare (x : int) (y : int) = compare x y end) - type key_handler = value Diff.t -> unit Lwt.t - type all_handler = key -> value Diff.t -> unit Lwt.t + type key_handler = value Diff.t -> unit + type all_handler = key -> value Diff.t -> unit let pp_value = Type.pp V.t let equal_opt_values = Type.(unstage (equal (option V.t))) @@ -105,7 +114,7 @@ struct type t = { id : int; (* unique watch manager id. *) - lock : Lwt_mutex.t; + lock : Eio.Mutex.t; (* protect [keys] and [glob]. *) mutable next : int; (* next id, to identify watch handlers. *) @@ -113,13 +122,13 @@ struct (* key handlers. *) mutable glob : (value KMap.t * all_handler) IMap.t; (* global handlers. *) - enqueue : (unit -> unit Lwt.t) -> unit; + enqueue : (unit -> unit) -> unit; (* enqueue notifications. *) clean : unit -> unit; (* destroy the notification thread. *) mutable listeners : int; (* number of listeners. *) - mutable stop_listening : unit -> unit Lwt.t; + mutable stop_listening : unit -> unit; (* clean-up listen resources. *) mutable notifications : int; (* number of notifcations. *) } @@ -142,13 +151,10 @@ struct t.glob <- IMap.empty; t.next <- 0 - let clear t = - Lwt_mutex.with_lock t.lock (fun () -> - clear_unsafe t; - Lwt.return_unit) + let clear t = Eio.Mutex.use_rw ~protect:true t.lock (fun () -> clear_unsafe t) let v () = - let lock = Lwt_mutex.create () in + let lock = Eio.Mutex.create () in let clean, enqueue = scheduler () in { lock; @@ -159,7 +165,7 @@ struct keys = IMap.empty; glob = IMap.empty; listeners = 0; - stop_listening = (fun () -> Lwt.return_unit); + stop_listening = (fun () -> ()); notifications = 0; } @@ -171,10 +177,9 @@ struct t.keys <- keys let unwatch t id = - Lwt_mutex.with_lock t.lock (fun () -> + Eio.Mutex.use_rw ~protect:true t.lock (fun () -> unwatch_unsafe t id; - if is_empty t then t.clean (); - Lwt.return_unit) + if is_empty t then t.clean ()) let mk old value = match (old, value) with @@ -184,10 +189,10 @@ struct | Some x, Some y -> `Updated (x, y) let protect f () = - Lwt.catch f (fun e -> - [%log.err - "watch callback got: %a\n%s" Fmt.exn e (Printexc.get_backtrace ())]; - Lwt.return_unit) + try f () + with e -> + [%log.err + "watch callback got: %a\n%s" Fmt.exn e (Printexc.get_backtrace ())] let pp_option = Fmt.option ~none:(Fmt.any "") let pp_key = Type.pp K.t @@ -227,7 +232,9 @@ struct t.glob <- glob; match !todo with | [] -> () - | ts -> t.enqueue (fun () -> Lwt_list.iter_p (fun x -> x ()) ts) + | ts -> + (* Check iter_p *) + t.enqueue (fun () -> List.iter (fun x -> x ()) ts) let notify_key_unsafe t key value = let todo = ref [] in @@ -255,15 +262,16 @@ struct t.keys <- keys; match !todo with | [] -> () - | ts -> t.enqueue (fun () -> Lwt_list.iter_p (fun x -> x ()) ts) + | ts -> + (* Check iter_p *) + t.enqueue (fun () -> List.iter (fun x -> x ()) ts) let notify t key value = - Lwt_mutex.with_lock t.lock (fun () -> - if is_empty t then Lwt.return_unit + Eio.Mutex.use_rw ~protect:true t.lock (fun () -> + if is_empty t then () else ( notify_all_unsafe t key value; - notify_key_unsafe t key value; - Lwt.return_unit)) + notify_key_unsafe t key value)) let watch_key_unsafe t key ?init f = let id = next t in @@ -272,9 +280,9 @@ struct id let watch_key t key ?init f = - Lwt_mutex.with_lock t.lock (fun () -> + Eio.Mutex.use_rw ~protect:true t.lock (fun () -> let id = watch_key_unsafe t ?init key f in - Lwt.return id) + id) let kmap_of_alist l = List.fold_left (fun map (k, v) -> KMap.add k v map) KMap.empty l @@ -286,21 +294,21 @@ struct id let watch t ?init f = - Lwt_mutex.with_lock t.lock (fun () -> + Eio.Mutex.use_rw ~protect:true t.lock (fun () -> let id = watch_unsafe t ?init f in - Lwt.return id) + id) let listen_dir t dir ~key ~value = let init () = if t.listeners = 0 then ( [%log.debug "%s: start listening to %s" (to_string t) dir]; - let+ f = + let f = !listen_dir_hook t.id dir (fun file -> match key file with - | None -> Lwt.return_unit + | None -> () | Some key -> let rec read n = - let* value = value key in + let value = value key in let n' = t.notifications in if n = n' then notify t key value else ( @@ -310,16 +318,14 @@ struct read t.notifications) in t.stop_listening <- f) - else ( - [%log.debug "%s: already listening on %s" (to_string t) dir]; - Lwt.return_unit) + else [%log.debug "%s: already listening on %s" (to_string t) dir] in - init () >|= fun () -> + init (); t.listeners <- t.listeners + 1; function | () -> if t.listeners > 0 then t.listeners <- t.listeners - 1; - if t.listeners <> 0 then Lwt.return_unit + if t.listeners <> 0 then () else ( [%log.debug "%s: stop listening to %s" (to_string t) dir]; t.stop_listening ()) diff --git a/src/irmin/watch_intf.ml b/src/irmin/watch_intf.ml index fad0d17a14..560f9b98bb 100644 --- a/src/irmin/watch_intf.ml +++ b/src/irmin/watch_intf.ml @@ -34,7 +34,7 @@ module type S = sig single key watchers for the store [t] and [a] the number of global watchers for [t]. *) - val notify : t -> key -> value option -> unit Lwt.t + val notify : t -> key -> value option -> unit (** Notify all listeners in the given watch state that a key has changed, with the new value associated to this key. [None] means the key has been removed. *) @@ -42,30 +42,27 @@ module type S = sig val v : unit -> t (** Create a watch state. *) - val clear : t -> unit Lwt.t + val clear : t -> unit (** Clear all register listeners in the given watch state. *) - val watch_key : - t -> key -> ?init:value -> (value Diff.t -> unit Lwt.t) -> watch Lwt.t + val watch_key : t -> key -> ?init:value -> (value Diff.t -> unit) -> watch (** Watch a given key for changes. More efficient than {!watch}. *) val watch : - t -> - ?init:(key * value) list -> - (key -> value Diff.t -> unit Lwt.t) -> - watch Lwt.t + t -> ?init:(key * value) list -> (key -> value Diff.t -> unit) -> watch (** Add a watch handler. To watch a specific key, use {!watch_key} which is more efficient. *) - val unwatch : t -> watch -> unit Lwt.t + val unwatch : t -> watch -> unit (** Remove a watch handler. *) val listen_dir : t -> string -> key:(string -> key option) -> - value:(key -> value option Lwt.t) -> - (unit -> unit Lwt.t) Lwt.t + value:(key -> value option) -> + unit -> + unit (** Register a thread looking for changes in the given directory and return a function to stop watching and free up resources. *) end @@ -78,8 +75,7 @@ module type Sigs = sig (** [workers ()] is the number of background worker threads managing event notification currently active. *) - type hook = - int -> string -> (string -> unit Lwt.t) -> (unit -> unit Lwt.t) Lwt.t + type hook = int -> string -> (string -> unit) -> unit -> unit (** The type for watch hooks. *) val none : hook diff --git a/test/irmin/dune b/test/irmin/dune index 4189f82922..b5db18dc04 100644 --- a/test/irmin/dune +++ b/test/irmin/dune @@ -9,9 +9,7 @@ irmin.mem irmin-test alcotest - alcotest-lwt - lwt - lwt.unix + eio_main hex logs logs.fmt diff --git a/test/irmin/generic-key/dune b/test/irmin/generic-key/dune index 96e1b41b09..b8eec5dfec 100644 --- a/test/irmin/generic-key/dune +++ b/test/irmin/generic-key/dune @@ -9,7 +9,4 @@ irmin.mem irmin-test alcotest - alcotest-lwt - lwt - lwt.unix vector)) diff --git a/test/irmin/generic-key/test_inlined_contents.ml b/test/irmin/generic-key/test_inlined_contents.ml index 755689678d..e5dc2b8f8b 100644 --- a/test/irmin/generic-key/test_inlined_contents.ml +++ b/test/irmin/generic-key/test_inlined_contents.ml @@ -38,28 +38,25 @@ module Keyed_by_value = struct let check_not_closed t = match !(t.instance) with None -> raise Closed | Some t -> t - let v _ = Lwt.return { instance = ref (Some ()) } + let v _ = { instance = ref (Some ()) } let mem t _ = let _ = check_not_closed t in - Lwt.return_true + true let unsafe_add t _ value = let _ = check_not_closed t in - Lwt.return { value } + { value } let add t v = unsafe_add t () v let find t k = let _ = check_not_closed t in - Lwt.return_some k.value + Some k.value - let index _ _ = Lwt.return_none + let index _ _ = None let batch t f = f (t :> Perms.read_write t) - - let close t = - t.instance := None; - Lwt.return_unit + let close t = t.instance := None end end diff --git a/test/irmin/generic-key/test_store_offset.ml b/test/irmin/generic-key/test_store_offset.ml index 3f9d8bdd4c..adcad130bc 100644 --- a/test/irmin/generic-key/test_store_offset.ml +++ b/test/irmin/generic-key/test_store_offset.ml @@ -57,13 +57,13 @@ module Slot_keyed_vector : Indexable.Maker_concrete_key1 = struct store constructor is memoised (modulo [close] semantics, which must be non-memoised), so we must use a singleton here. *) let singleton = { data = Vector.create ~dummy:None; id = object end } in - fun _ -> Lwt.return { instance = ref (Some singleton) } + fun _ -> { instance = ref (Some singleton) } type nonrec key = Hash.t key [@@deriving irmin] type value = Value.t type hash = Hash.t [@@deriving irmin ~equal] - let index _ _ = Lwt.return_none + let index _ _ = None module Key = struct type t = key [@@deriving irmin] @@ -95,7 +95,7 @@ module Slot_keyed_vector : Indexable.Maker_concrete_key1 = struct let t = check_not_closed t in Vector.push t.data (Some (hash, v)); let key = { slot = Vector.length t.data - 1; hash; store_id = t.id } in - Lwt.return key + key let add t v = unsafe_add t (Hash.hash v) v @@ -103,26 +103,24 @@ module Slot_keyed_vector : Indexable.Maker_concrete_key1 = struct let t = check_not_closed t in check_key_belongs_to_store __POS__ k t; match Vector.get t.data k.slot with - | exception Not_found -> Lwt.return_none + | exception Not_found -> None | None -> Alcotest.failf "Invalid key slot %d. No data contained here." k.slot | Some (recovered_hash, data) -> check_hash_is_consistent __POS__ k recovered_hash; - Lwt.return (Some data) + Some data let mem t k = let t = check_not_closed t in check_key_belongs_to_store __POS__ k t; assert (k.slot < Vector.length t.data); - Lwt.return_true + true let batch t f = let _ = check_not_closed t in f (t :> Perms.read_write t) - let close t = - t.instance := None; - Lwt.return_unit + let close t = t.instance := None end end diff --git a/test/irmin/test.ml b/test/irmin/test.ml index 1c3cf66d07..277417b8cb 100644 --- a/test/irmin/test.ml +++ b/test/irmin/test.ml @@ -16,15 +16,11 @@ module Test_node = Irmin_test.Node.Make (Irmin.Node.Generic_key.Make) -let lift_suite_to_lwt : - unit Alcotest.test_case list -> unit Alcotest_lwt.test_case list = - List.map (fun (n, s, f) -> (n, s, Fun.const (Lwt.wrap f))) - let suite = [ - ("lru", Test_lru.suite |> lift_suite_to_lwt); + ("lru", Test_lru.suite); ("tree", Test_tree.suite); - ("node", Test_node.suite |> lift_suite_to_lwt); + ("node", Test_node.suite); ("hash", Test_hash.suite); ("conf", Test_conf.suite); ] @@ -33,4 +29,4 @@ let () = Logs.set_level (Some Debug); Logs.set_reporter (Irmin_test.reporter ()); Random.self_init (); - Lwt_main.run (Alcotest_lwt.run "irmin" suite) + Eio_main.run @@ fun _ -> Alcotest.run "irmin" suite diff --git a/test/irmin/test_conf.ml b/test/irmin/test_conf.ml index 140cc146d0..311bc04cb0 100644 --- a/test/irmin/test_conf.ml +++ b/test/irmin/test_conf.ml @@ -52,7 +52,7 @@ let test_duplicate_key_names () = let suite = [ - Alcotest_lwt.test_case_sync "conf" `Quick test_conf; - Alcotest_lwt.test_case_sync "duplicate key names" `Quick + Alcotest.test_case_sync "conf" `Quick test_conf; + Alcotest.test_case_sync "duplicate key names" `Quick test_duplicate_key_names; ] diff --git a/test/irmin/test_conf.mli b/test/irmin/test_conf.mli index 3258b5f81c..8d313cc416 100644 --- a/test/irmin/test_conf.mli +++ b/test/irmin/test_conf.mli @@ -14,4 +14,4 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -val suite : unit Alcotest_lwt.test_case list +val suite : unit Alcotest.test_case list diff --git a/test/irmin/test_hash.ml b/test/irmin/test_hash.ml index ce653b0b3c..7c055c8a55 100644 --- a/test/irmin/test_hash.ml +++ b/test/irmin/test_hash.ml @@ -34,4 +34,4 @@ let test_short_hash () = in () -let suite = [ Alcotest_lwt.test_case_sync "short_hash" `Quick test_short_hash ] +let suite = [ Alcotest.test_case "short_hash" `Quick test_short_hash ] diff --git a/test/irmin/test_hash.mli b/test/irmin/test_hash.mli index 3258b5f81c..8d313cc416 100644 --- a/test/irmin/test_hash.mli +++ b/test/irmin/test_hash.mli @@ -14,4 +14,4 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -val suite : unit Alcotest_lwt.test_case list +val suite : unit Alcotest.test_case list diff --git a/test/irmin/test_tree.ml b/test/irmin/test_tree.ml index f11403a17d..c00316a492 100644 --- a/test/irmin/test_tree.ml +++ b/test/irmin/test_tree.ml @@ -58,8 +58,8 @@ module Alcotest = struct let concrete_tree = gtestable Tree.concrete_t in fun ?__POS__:pos msg ~expected b_lwt -> b_lwt - >>= Tree.to_concrete - >|= Alcotest.check ?pos concrete_tree msg expected + |> Tree.to_concrete + |> Alcotest.check ?pos concrete_tree msg expected let inspect = Alcotest.testable @@ -74,33 +74,32 @@ module Alcotest = struct end let check_exn_lwt ~exn_type pos f = - Lwt.catch - (fun () -> - let* _ = f () in - Alcotest.failf ~pos - "Expected a `%s` exception, but no exception was raised." - (match exn_type with - | `Dangling_hash -> "Dangling_hash" - | `Pruned_hash -> "Pruned_hash")) - (fun exn -> - match (exn_type, exn) with - | `Dangling_hash, Tree.Dangling_hash _ -> Lwt.return_unit - | `Pruned_hash, Tree.Pruned_hash _ -> Lwt.return_unit - | _ -> Lwt.fail exn) + try + let _ = f () in + Alcotest.failf ~pos + "Expected a `%s` exception, but no exception was raised." + (match exn_type with + | `Dangling_hash -> "Dangling_hash" + | `Pruned_hash -> "Pruned_hash") + with exn -> ( + match (exn_type, exn) with + | `Dangling_hash, Tree.Dangling_hash _ -> () + | `Pruned_hash, Tree.Pruned_hash _ -> () + | _ -> raise exn) (* Let-syntax for testing all possible combinations of a set of choices: *) -let ( let&* ) x f = Lwt_list.iter_s f x +let ( let&* ) x f = List.iter f x and ( and&* ) l m = List.concat_map (fun a -> List.map (fun b -> (a, b)) m) l let ( >> ) f g x = g (f x) let c ?(info = Metadata.default) blob = `Contents (blob, info) let invalid_tree () = - let+ repo = Store.Repo.v (Irmin_mem.config ()) in + let repo = Store.Repo.v (Irmin_mem.config ()) in let hash = Store.Hash.hash (fun f -> f "") in Tree.shallow repo (`Node hash) -let test_bindings _ () = +let test_bindings () = let tree = Tree.of_concrete (`Tree [ ("aa", c "0"); ("ab", c "1"); ("a", c "2"); ("b", c "3") ]) @@ -110,9 +109,9 @@ let test_bindings _ () = "Bindings are reported in lexicographic order" [ "a"; "aa"; "ab"; "b" ] in (* [Tree.list] returns all keys in lexicographic order *) - Tree.list tree [] >|= (List.map fst >> check_sorted) + Tree.list tree [] |> (List.map fst >> check_sorted) -let test_paginated_bindings _ () = +let test_paginated_bindings () = let tree = Tree.of_concrete (`Tree @@ -128,60 +127,60 @@ let test_paginated_bindings _ () = Alcotest.(check (list string)) "Bindings are reported in lexicographic order" expected in - let* () = + let () = Tree.list ~offset:0 ~length:2 tree [] - >|= (List.map fst >> check_sorted [ "a"; "aa" ]) + |> (List.map fst >> check_sorted [ "a"; "aa" ]) in - let* () = + let () = Tree.list ~offset:2 ~length:3 tree [] - >|= (List.map fst >> check_sorted [ "aaa"; "b"; "bbb" ]) + |> (List.map fst >> check_sorted [ "aaa"; "b"; "bbb" ]) in - let* () = + let () = Tree.list ~offset:1 ~length:1 tree [] - >|= (List.map fst >> check_sorted [ "aa" ]) + |> (List.map fst >> check_sorted [ "aa" ]) in - let* () = + let () = Tree.list ~offset:4 ~length:2 tree [] - >|= (List.map fst >> check_sorted [ "bbb" ]) + |> (List.map fst >> check_sorted [ "bbb" ]) in - let* () = - Tree.list ~offset:5 ~length:2 tree [] >|= (List.map fst >> check_sorted []) + let () = + Tree.list ~offset:5 ~length:2 tree [] |> (List.map fst >> check_sorted []) in - Lwt.return_unit + () let tree bs = Tree.of_concrete (`Tree bs) (** Basic tests of the [Tree.diff] operation. *) -let test_diff _ () = +let test_diff () = let empty = tree [] in let single = tree [ ("k", c "v") ] in (* Adding a single key *) - let* () = + let () = Tree.diff empty single - >|= Alcotest.(check diffs) - "Added [k \226\134\146 v]" - [ ([ "k" ], `Added ("v", Default)) ] + |> Alcotest.(check diffs) + "Added [k \226\134\146 v]" + [ ([ "k" ], `Added ("v", Default)) ] in (* Removing a single key *) - let* () = + let () = Tree.diff single empty - >|= Alcotest.(check diffs) - "Removed [k \226\134\146 v]" - [ ([ "k" ], `Removed ("v", Default)) ] + |> Alcotest.(check diffs) + "Removed [k \226\134\146 v]" + [ ([ "k" ], `Removed ("v", Default)) ] in (* Changing metadata *) Tree.diff (tree [ ("k", c ~info:Left "v") ]) (tree [ ("k", c ~info:Right "v") ]) - >|= Alcotest.(check diffs) - "Changed metadata" - [ ([ "k" ], `Updated (("v", Left), ("v", Right))) ] + |> Alcotest.(check diffs) + "Changed metadata" + [ ([ "k" ], `Updated (("v", Left), ("v", Right))) ] -let test_empty _ () = - let* () = +let test_empty () = + let () = Alcotest.check_tree_lwt "The empty tree is empty" ~expected:(`Tree []) - (Lwt.return (Tree.empty ())) + (Tree.empty ()) in (* Ensure that different [empty] values have disjoint cache state. @@ -189,12 +188,12 @@ let test_empty _ () = This is a regression test for a bug in which all [Tree.empty] values had shared cache state and any keys obtained from [export] were discarded (to avoid sharing keys from different repositories). *) - let* () = - let* repo = Store.Repo.v (Irmin_mem.config ()) in + let () = + let repo = Store.Repo.v (Irmin_mem.config ()) in let empty_exported = Tree.empty () and empty_not_exported = Tree.empty () in - let+ () = + let () = Store.Backend.Repo.batch repo (fun c n _ -> - Store.save_tree repo c n empty_exported >|= ignore) + Store.save_tree repo c n empty_exported |> ignore) in Alcotest.(check inspect) "The exported empty tree is now in Key form" (`Node `Key) @@ -204,29 +203,28 @@ let test_empty _ () = (`Node `Map) (Tree.inspect empty_not_exported) in + () - Lwt.return_unit - -let test_add _ () = +let test_add () = let sample_tree ?(ab = "ab_v") ?ac () : Tree.concrete = let ac = match ac with Some ac -> [ ("ac", ac) ] | None -> [] in `Tree [ ("a", `Tree ([ ("aa", c "0"); ("ab", c ab) ] @ ac)); ("b", c "3") ] in - let* () = + let () = Alcotest.check_tree_lwt "Adding a root value to an empty tree" ~expected:(c "1") (Tree.add (Tree.empty ()) [] "1") in - let* () = + let () = let t = Tree.of_concrete (sample_tree ()) in let expected = sample_tree ~ab:"new_value" () in Alcotest.check_tree_lwt "Replacing an existing value in a tree" ~expected (Tree.add t [ "a"; "ab" ] "new_value") in - let* () = + let () = let t = Tree.of_concrete (sample_tree ()) in let expected = sample_tree ~ac:(`Tree [ ("aca", c "new_value") ]) () in Alcotest.check_tree_lwt @@ -236,60 +234,60 @@ let test_add _ () = (Tree.add t [ "a"; "ac"; "aca" ] "new_value") in - let* () = + let () = let t = Tree.of_concrete (c "1") in - let+ t' = Tree.add t [] "1" in + let t' = Tree.add t [] "1" in Alcotest.assert_ "Re-adding a root value preserves physical equality" (t == t') in - let* () = + let () = let t = tree [ ("a", `Tree [ ("b", c "1") ]) ] in - let+ t' = Tree.add t [ "a"; "b" ] "1" in + let t' = Tree.add t [ "a"; "b" ] "1" in Alcotest.assert_ "Re-adding a non-root value preserves physical equality" (t == t') in - Lwt.return_unit + () -let test_remove _ () = +let test_remove () = let tree = Tree.of_concrete (`Tree [ ("a", `Tree [ ("aa", c "0"); ("ab", c "1") ]); ("b", c "3") ]) in - let* () = + let () = let t = Tree.empty () in - let+ t' = Tree.remove t [] in + let t' = Tree.remove t [] in Alcotest.assert_ "Removing in an empty tree preserves physical equality" (t == t') in - let* () = - let+ tree' = Tree.remove tree [ "a"; "non"; "existent"; "path" ] in + let () = + let tree' = Tree.remove tree [ "a"; "non"; "existent"; "path" ] in Alcotest.assert_ "Removing at a non-existent path in a non-empty tree preserves physical \ equality" (tree == tree') in - let* () = + let () = let tree = Tree.of_concrete (c "1") in - let+ tree' = Tree.remove tree [ "a"; "non"; "existent"; "path" ] in + let tree' = Tree.remove tree [ "a"; "non"; "existent"; "path" ] in Alcotest.assert_ "Removing at a non-existent path in a root contents value preserves \ physical equality" (tree == tree') in - let* () = + let () = Alcotest.check_tree_lwt "Removing a root contents value results in an empty root node." ~expected:(`Tree []) (Tree.remove (Tree.of_concrete (c "1")) []) in - Lwt.return_unit + () (* Build a function that requires a given input, always returns a given output, and can be called at most once. *) @@ -305,7 +303,7 @@ let transform_once : type a b. a Type.t -> a -> b -> a -> b = if equal source x then target else Alcotest.failf "Expected %a but got %a" pp source pp x -let test_update _ () = +let test_update () = let unrelated_binding = ("a_unrelated", c "<>") in let abc ?info v = `Tree @@ -314,7 +312,7 @@ let test_update _ () = let abc1 = Tree.of_concrete (abc "1") in let ( --> ) = transform_once [%typ: string option] in - let* () = + let () = Alcotest.check_tree_lwt "Changing the value of a root contents node results in a new contents \ node." @@ -322,14 +320,14 @@ let test_update _ () = (Tree.update (Tree.of_concrete (c "1")) [] (Some "1" --> Some "2")) in - let* () = + let () = Alcotest.check_tree_lwt "Removing a root contents node results in an empty root node." ~expected:(`Tree []) (Tree.update (Tree.of_concrete (c "1")) [] (Some "1" --> None)) in - let* () = + let () = Alcotest.check_tree_lwt "Updating a root node to a contents value removes all bindings and sets \ the correct metadata." @@ -337,17 +335,17 @@ let test_update _ () = (Tree.update ~metadata:Metadata.Right abc1 [] (None --> Some "2")) in - let* () = + let () = (* Replacing a root node with a dangling hash does not raise an exception. *) - let* invalid_tree = invalid_tree () in + let invalid_tree = invalid_tree () in Tree.update_tree abc1 [] (function | Some _ -> Some invalid_tree | None -> assert false) - >|= ignore + |> ignore in - let* () = + let () = Alcotest.check_tree_lwt "Updating at an existing contents path changes the contents value \ appropriately." @@ -355,17 +353,17 @@ let test_update _ () = (Tree.update abc1 [ "a"; "b"; "c" ] (Some "1" --> Some "2")) in - let* () = + let () = let s = "1" and s' = "1" ^ "" in assert (s != s'); - let+ abc1' = Tree.update abc1 [ "a"; "b"; "c" ] (Some s --> Some s') in + let abc1' = Tree.update abc1 [ "a"; "b"; "c" ] (Some s --> Some s') in Alcotest.assert_ "Performing a no-op change to tree contents preserves physical equality" (abc1 == abc1') in - let* () = - let+ abc1' = + let () = + let abc1' = Tree.update_tree abc1 [ "a"; "b" ] (function | Some t -> Some t | None -> assert false) @@ -376,7 +374,7 @@ let test_update _ () = (abc1 == abc1') in - let* () = + let () = Alcotest.check_tree_lwt "Changing the metadata of an existing contents value updates the tree." ~expected:(abc ~info:Metadata.Left "1") @@ -384,7 +382,7 @@ let test_update _ () = (Some "1" --> Some "1")) in - let* () = + let () = Alcotest.check_tree_lwt "Removing a siblingless contents value causes newly-empty directories to \ be pruned." @@ -392,7 +390,7 @@ let test_update _ () = (Tree.update abc1 [ "a"; "b"; "c" ] (Some "1" --> None)) in - let* () = + let () = Alcotest.check_tree_lwt "Removing a siblingless node causes newly-empty directories to be pruned" ~expected:(`Tree [ unrelated_binding ]) @@ -401,7 +399,7 @@ let test_update _ () = | None -> assert false)) in - let* () = + let () = Alcotest.check_tree_lwt "Updating at a non-existent contents path adds a new directory entry." ~expected: @@ -413,7 +411,7 @@ let test_update _ () = (Tree.update abc1 [ "a"; "b"; "c'" ] (None --> Some "new_value")) in - let* () = + let () = Alcotest.check_tree_lwt "Updating at an existing node path replaces the subtree with the given \ element." @@ -422,7 +420,7 @@ let test_update _ () = (Tree.update abc1 [ "a"; "b" ] (None --> Some "new_value")) in - let* () = + let () = Alcotest.check_tree_lwt "Updating at a path in an empty tree creates the necessary intermediate \ nodes with the new contents." @@ -430,23 +428,23 @@ let test_update _ () = (Tree.update (Tree.empty ()) [ "a"; "b"; "c" ] (None --> Some "1")) in - let* () = - let+ abc1' = Tree.update abc1 [ "a"; "b"; "c"; "d"; "e" ] (None --> None) in + let () = + let abc1' = Tree.update abc1 [ "a"; "b"; "c"; "d"; "e" ] (None --> None) in Alcotest.assert_ "Removing at a non-existent path in a non-empty tree preserves physical \ equality." (abc1 == abc1') in - let* () = + let () = let t = Tree.empty () in - let+ t' = Tree.update t [] (None --> None) in + let t' = Tree.update t [] (None --> None) in Alcotest.assert_ "Removing from an empty tree preserves physical equality" (t == t') in - let* () = - let+ abc1' = + let () = + let abc1' = Tree.update_tree abc1 [ "a"; "b"; "d" ] (function | None -> Some (Tree.empty ()) | Some _ -> assert false) @@ -456,68 +454,74 @@ let test_update _ () = (abc1 == abc1') in - Lwt.return_unit + () (* Correct stats for a completely lazy tree *) let lazy_stats = Tree.{ nodes = 0; leafs = 0; skips = 1; depth = 0; width = 0 } (* Take a tree and persist it to some underlying store, making it lazy. *) -let persist_tree ?clear : Store.tree -> Store.tree Lwt.t = +let persist_tree ?clear : Store.tree -> Store.tree = fun tree -> - let* store = Store.Repo.v (Irmin_mem.config ()) >>= Store.empty in - let* () = Store.set_tree_exn ?clear ~info:Store.Info.none store [] tree in + let store = Store.Repo.v (Irmin_mem.config ()) >>= Store.empty in + let () = Store.set_tree_exn ?clear ~info:Store.Info.none store [] tree in Store.tree store type path = Store.Path.t [@@deriving irmin ~pp ~equal] -let test_clear _ () = +let test_clear () = (* 1. Build a tree *) - let size = 830829 in - let* t = + Eio.traceln "Clear 1"; + let size = 256 in + let t = List.init size string_of_int - |> Lwt_list.fold_left_s (fun acc i -> Tree.add acc [ i ] i) (Tree.empty ()) + |> List.fold_left (fun acc i -> Tree.add acc [ i ] i) (Tree.empty ()) in + Eio.traceln "Clear 2"; (* Check the state of the root and root/42 *) Alcotest.(check inspect) "Before clear, root" (`Node `Map) (Tree.inspect t); - let* () = + let () = Tree.stats ~force:false t - >|= Alcotest.(gcheck Tree.stats_t) - "Before clear, root node is eagerly evaluated" - { nodes = 1; leafs = size; skips = 0; depth = 1; width = size } + |> Alcotest.(gcheck Tree.stats_t) + "Before clear, root node is eagerly evaluated" + { nodes = 1; leafs = size; skips = 0; depth = 1; width = size } in - let* entry42 = Tree.find_tree t [ "42" ] >|= Option.get in + Eio.traceln "Clear 3"; + let entry42 = Tree.find_tree t [ "42" ] |> Option.get in Alcotest.(check inspect) "Before clear, root/42" `Contents (Tree.inspect entry42); - let* () = + Eio.traceln "Clear 4"; + let () = let dont_skip k = Alcotest.failf "should not have skipped %a" pp_path k in Tree.fold ~force:(`False dont_skip) entry42 () in (* 2. Clear on non-persisted *) + Eio.traceln "Clear 5"; Tree.clear t; + Eio.traceln "Clear 6"; (* The state of the tree shouldn't have changed after this clear *) Alcotest.(check inspect) "Before persist" (`Node `Map) (Tree.inspect t); - let* () = + let () = Tree.stats ~force:false t - >|= Alcotest.(gcheck Tree.stats_t) - "Before persist, root node is eagerly evaluated" - { nodes = 1; leafs = size; skips = 0; depth = 1; width = size } + |> Alcotest.(gcheck Tree.stats_t) + "Before persist, root node is eagerly evaluated" + { nodes = 1; leafs = size; skips = 0; depth = 1; width = size } in - let* entry42 = Tree.find_tree t [ "42" ] >|= Option.get in + let entry42 = Tree.find_tree t [ "42" ] |> Option.get in Alcotest.(check inspect) "Before persist" `Contents (Tree.inspect entry42); - let* () = + let () = let dont_skip k = Alcotest.failf "should not have skipped %a" pp_path k in Tree.fold ~force:(`False dont_skip) entry42 () in (* 3. Persist (and implicitly clear) *) - let* _ = persist_tree t in + let _ = persist_tree t in (* Check the state of the root *) Alcotest.(check inspect) "After persist+clear" (`Node `Key) (Tree.inspect t); - let* () = + let () = Tree.stats ~force:false t - >|= Alcotest.(gcheck Tree.stats_t) - "After persist+clear, root node is no longer cached" lazy_stats + |> Alcotest.(gcheck Tree.stats_t) + "After persist+clear, root node is no longer cached" lazy_stats in - Lwt.return_unit + () let test_minimal_reads _ () = (* 1. Build a tree *) @@ -545,32 +549,32 @@ let test_minimal_reads _ () = let with_binding k v t = Tree.add_tree t k v let clear_and_assert_lazy tree = - let* _ = persist_tree tree in + let _ = persist_tree tree in Tree.clear tree; Tree.stats ~force:false tree - >|= Alcotest.(gcheck Tree.stats_t) - "Initially the tree is entirely lazy" lazy_stats + |> Alcotest.(gcheck Tree.stats_t) + "Initially the tree is entirely lazy" lazy_stats -let test_fold_force _ () = - let* invalid_tree = - let+ repo = Store.Repo.v (Irmin_mem.config ()) in +let test_fold_force () = + let invalid_tree = + let repo = Store.Repo.v (Irmin_mem.config ()) in let hash = Store.Hash.hash (fun f -> f "") in Tree.shallow repo (`Node hash) in (* Ensure that [fold] doesn't force a lazy tree when [~force:(`False f)], and that [f] is called the correct number of times. *) - let* () = - let* tree = + let () = + let tree = Tree.singleton [ "existing"; "subtree" ] "value" |> with_binding [ "dangling"; "subtree"; "hash" ] invalid_tree - >>= with_binding [ "other"; "lazy"; "path" ] invalid_tree + |> with_binding [ "other"; "lazy"; "path" ] invalid_tree in - let force = `False (Lwt.wrap2 List.cons) in + let force = `False List.cons in Tree.fold ~force tree [] - >|= Alcotest.(check (slist (list string) Stdlib.compare)) - "Unforced paths" - [ [ "dangling"; "subtree"; "hash" ]; [ "other"; "lazy"; "path" ] ] + |> Alcotest.(check (slist (list string) Stdlib.compare)) + "Unforced paths" + [ [ "dangling"; "subtree"; "hash" ]; [ "other"; "lazy"; "path" ] ] in let create_sample_tree () = Tree.of_concrete @@ -586,29 +590,29 @@ let test_fold_force _ () = in (* Ensure that [fold ~force:`True ~cache:true] forces all lazy trees. *) - let* () = + let () = let sample_tree = create_sample_tree () in - let* () = clear_and_assert_lazy sample_tree in - Tree.fold ~force:`True ~cache:true sample_tree () >>= fun () -> + let () = clear_and_assert_lazy sample_tree in + Tree.fold ~force:`True ~cache:true sample_tree (); Tree.stats ~force:false sample_tree - >|= Alcotest.(gcheck Tree.stats_t) - "After folding, the tree is eagerly evaluated" eager_stats + |> Alcotest.(gcheck Tree.stats_t) + "After folding, the tree is eagerly evaluated" eager_stats in (* Ensure that [fold ~force:`True ~cache:false] visits all children and does not leave them cached. *) - let* () = + let () = let sample_tree = create_sample_tree () in - clear_and_assert_lazy sample_tree >>= fun () -> - let* contents = + clear_and_assert_lazy sample_tree; + let contents = Tree.fold ~force:`True ~cache:false - ~contents:(fun _ -> Lwt.wrap2 List.cons) + ~contents:(fun _ -> List.cons) sample_tree [] in - let+ () = + let () = Tree.stats ~force:false sample_tree - >|= Alcotest.(gcheck Tree.stats_t) - "After folding, the tree is cleared" lazy_stats + |> Alcotest.(gcheck Tree.stats_t) + "After folding, the tree is cleared" lazy_stats in Alcotest.(check (slist string compare)) "During forced fold, all contents were traversed" @@ -618,12 +622,12 @@ let test_fold_force _ () = (* Ensure that [fold ~force:`True ~cache:false] visits newly added values and updated values only once and does not visit removed values. *) - let* () = + let () = let sample_tree = create_sample_tree () in - let* () = clear_and_assert_lazy sample_tree in - Tree.remove sample_tree [ "a"; "ab" ] >>= fun updated_tree -> - Tree.add updated_tree [ "a"; "ad" ] "v-ad" >>= fun updated_tree -> - Tree.add updated_tree [ "a"; "ac" ] "v-acc" >>= fun updated_tree -> + let () = clear_and_assert_lazy sample_tree in + Tree.remove sample_tree [ "a"; "ab" ] |> fun updated_tree -> + Tree.add updated_tree [ "a"; "ad" ] "v-ad" |> fun updated_tree -> + Tree.add updated_tree [ "a"; "ac" ] "v-acc" |> fun updated_tree -> let visited = ref [] in let contents k v () = if equal_path k [ "a"; "ab" ] then @@ -635,16 +639,16 @@ let test_fold_force _ () = if List.mem ~equal:equal_path k !visited then Alcotest.failf "Visited node at %a twice during fold" pp_path k else visited := k :: !visited; - Lwt.return_unit + () in - Tree.fold ~force:`True ~cache:false ~contents updated_tree () >|= fun () -> + Tree.fold ~force:`True ~cache:false ~contents updated_tree (); Alcotest.(check bool) "Newly added contents visited" (List.mem ~equal:equal_path [ "a"; "ad" ] !visited) true in - Lwt.return_unit + () (* Tests of "broken" trees: trees that can't be dereferenced. Tree currently supports two varieties of broken tree: @@ -656,10 +660,10 @@ let test_fold_force _ () = Attempted dereferences should raise [Pruned_hash]. *) module Broken = struct let shallow_of_ptr kinded_key = - let+ repo = Store.Repo.v (Irmin_mem.config ()) in + let repo = Store.Repo.v (Irmin_mem.config ()) in Tree.shallow repo kinded_key - let pruned_of_ptr kinded_hash = Lwt.return (Tree.pruned kinded_hash) + let pruned_of_ptr kinded_hash = Tree.pruned kinded_hash let random_string32 = Irmin.Type.(unstage (random (string_of (`Fixed 32)))) let random_contents () = @@ -672,16 +676,16 @@ module Broken = struct let value_ptr = `Node (Tree.hash value) in (value, value_ptr) - let test_hashes _ () = + let test_hashes () = let&* leaf_type, (leaf, leaf_ptr) = [ ("contents", random_contents ()); ("node", random_node ()) ] and&* operation_name, operation = [ ("shallow", shallow_of_ptr); ("pruned", pruned_of_ptr) ] and&* path = [ []; [ "k" ] ] in - let* leaf_broken = operation leaf_ptr in - let* hash_actual = Tree.(add_tree (empty ())) path leaf >|= Tree.hash in - let+ hash_expected = - Tree.(add_tree (empty ())) path leaf_broken >|= Tree.hash + let leaf_broken = operation leaf_ptr in + let hash_actual = Tree.(add_tree (empty ())) path leaf |> Tree.hash in + let hash_expected = + Tree.(add_tree (empty ())) path leaf_broken |> Tree.hash in Alcotest.(gcheck Store.Hash.t) (Fmt.str @@ -692,12 +696,12 @@ module Broken = struct path leaf_type) hash_expected hash_actual - let test_trees _ () = + let test_trees () = let run_tests ~exn_type ~broken_contents ~broken_node ~path = [%logs.app "Testing operations on a tree with a broken position at %a" pp_path path]; - let* broken_leaf = Tree.(add_tree (empty ())) path broken_contents in - let* broken_node = Tree.(add_tree (empty ())) path broken_node in + let broken_leaf = Tree.(add_tree (empty ())) path broken_contents in + let broken_node = Tree.(add_tree (empty ())) path broken_node in let beneath = path @ [ "a"; "b"; "c" ] in let blob = "v" and node = tree [ ("k", c "v") ] in let add_blob_or_node path = @@ -708,22 +712,22 @@ module Broken = struct in (* [add] on broken nodes/contents replaces the broken position. *) - let* () = + let () = let&* broken = [ broken_leaf; broken_node ] and&* add = add_blob_or_node path in - let* expected = add (Tree.empty ()) >>= Tree.to_concrete in + let expected = add (Tree.empty ()) |> Tree.to_concrete in Alcotest.check_tree_lwt ~__POS__ "" ~expected (add broken) in (* [add] _beneath_ a broken contents value also works fine, but on broken nodes an exception is raised. (We can't know what the node's contents are, so there's no valid return tree.) *) - let* () = + let () = let&* add_beneath = add_blob_or_node beneath in - let* expected = add_beneath (Tree.empty ()) >>= Tree.to_concrete in + let expected = add_beneath (Tree.empty ()) |> Tree.to_concrete in Alcotest.check_tree_lwt ~__POS__ "" ~expected (add_beneath broken_leaf) in - let* () = + let () = let&* add_beneath = add_blob_or_node beneath in check_exn_lwt ~exn_type __POS__ (fun () -> add_beneath broken_node) in @@ -731,85 +735,84 @@ module Broken = struct (* [find] on broken contents raises an exception (can't recover contents), but _beneath_ broken contents it returns [None] (mismatched type). (The behaviour is reversed for broken nodes.) *) - let* () = + let () = check_exn_lwt ~exn_type __POS__ (fun () -> Tree.find broken_leaf path) in - let* () = + let () = check_exn_lwt ~exn_type __POS__ (fun () -> Tree.find broken_node beneath) in - let* () = + let () = Tree.find broken_leaf beneath - >|= Alcotest.(check ~pos:__POS__ (option reject)) "" None + |> Alcotest.(check ~pos:__POS__ (option reject)) "" None in - let* () = + let () = Store.Tree.find broken_node path - >|= Alcotest.(check ~pos:__POS__ (option reject)) "" None + |> Alcotest.(check ~pos:__POS__ (option reject)) "" None in (* [list] on (or beneath) broken contents returns the empty list, but on (or beneath) broken nodes an exception is raised. *) - let* () = + let () = let&* path = [ path; beneath ] in Tree.list broken_leaf path - >|= Alcotest.(check ~pos:__POS__ (list reject)) "" [] + |> Alcotest.(check ~pos:__POS__ (list reject)) "" [] in - let* () = + let () = let&* path = [ path; beneath ] in check_exn_lwt ~exn_type __POS__ (fun () -> Tree.list broken_node path) in - Lwt.return_unit + () in let&* path = [ []; [ "k" ] ] and&* exn_type, tree_of_ptr = [ (`Dangling_hash, shallow_of_ptr); (`Pruned_hash, pruned_of_ptr) ] in - let* broken_contents = tree_of_ptr (snd (random_contents ())) in - let* broken_node = tree_of_ptr (snd (random_node ())) in + let broken_contents = tree_of_ptr (snd (random_contents ())) in + let broken_node = tree_of_ptr (snd (random_node ())) in run_tests ~exn_type ~broken_contents ~broken_node ~path - let test_pruned_fold _ () = + let test_pruned_fold () = let&* _, ptr = [ random_contents (); random_node () ] and&* path = [ []; [ "k" ] ] in - let* tree = Tree.(add_tree (empty ())) path (Tree.pruned ptr) in + let tree = Tree.(add_tree (empty ())) path (Tree.pruned ptr) in (* Folding over a pruned tree with [force:`True] should fail: *) - let* () = + let () = check_exn_lwt ~exn_type:`Pruned_hash __POS__ (fun () -> Tree.fold ~force:`True tree ()) in (* But folding with [force:`False] should not: *) - let* () = Tree.fold ~force:(`False (fun _ -> Lwt.return)) tree () in + let () = Tree.fold ~force:(`False (fun _ -> Fun.id)) tree () in (* Similarly, attempting to export a pruned tree should fail: *) - let* repo = Store.Repo.v (Irmin_mem.config ()) in + let repo = Store.Repo.v (Irmin_mem.config ()) in check_exn_lwt ~exn_type:`Pruned_hash __POS__ (fun () -> Store.Backend.Repo.batch repo (fun c n _ -> - Store.save_tree repo c n tree >|= ignore)) + Store.save_tree repo c n tree |> ignore)) end -let test_kind_empty_path _ () = +let test_kind_empty_path () = let cont = c "c" |> Tree.of_concrete in let tree = `Tree [ ("k", c "c") ] |> Tree.of_concrete in - let* k = Tree.kind cont [] in + let k = Tree.kind cont [] in Alcotest.(check (option (gtestable kind_t))) "Kind of empty path in content" (Some `Contents) k; - let* k = Tree.kind tree [] in + let k = Tree.kind tree [] in Alcotest.(check (option (gtestable kind_t))) - "Kind of empty path in tree" (Some `Node) k; - Lwt.return_unit + "Kind of empty path in tree" (Some `Node) k -let test_generic_equality _ () = +let test_generic_equality () = (* Regression test for a bug in which the equality derived from [tree_t] did not respect equivalences between in-memory trees and lazy trees. *) - let* tree = persist_tree (tree [ ("k", c "v") ]) in - let+ should_be_empty = Tree.remove tree [ "k" ] in + let tree = persist_tree (tree [ ("k", c "v") ]) in + let should_be_empty = Tree.remove tree [ "k" ] in Alcotest.(gcheck Store.tree_t) "Modified empty tree is equal to [(Tree.empty ())]" (Tree.empty ()) should_be_empty -let test_is_empty _ () = +let test_is_empty () = (* Test for equivalence against an [is_equal] derived from generic equality, for backwards compatibility. *) let is_empty = @@ -824,11 +827,11 @@ let test_is_empty _ () = let kv = tree [ ("k", c "v") ] in let () = Alcotest.(check bool) "empty tree" true (is_empty (Tree.empty ())) in let () = Alcotest.(check bool) "non-empty tree" false (is_empty kv) in - let* () = - let+ tree = Tree.remove kv [ "k" ] in + let () = + let tree = Tree.remove kv [ "k" ] in Alcotest.(check bool) "emptied tree" true (is_empty tree) in - let* repo = Store.Repo.v (Irmin_mem.config ()) in + let repo = Store.Repo.v (Irmin_mem.config ()) in let () = let shallow_empty = Tree.(shallow repo (`Node (hash (empty ())))) in Alcotest.(check bool) "shallow empty tree" true (is_empty shallow_empty) @@ -838,16 +841,16 @@ let test_is_empty _ () = Alcotest.(check bool) "shallow non-empty tree" false (is_empty shallow_empty) in - Lwt.return_unit + () -let test_of_concrete _ () = - let* () = +let test_of_concrete () = + let () = let aa = ("aa", c "aa-v") in let ac = ("ac", c "ac-v") in let input = tree [ ("a", `Tree [ aa; ("ab", `Tree []); ac ]) ] in let pruned = `Tree [ ("a", `Tree [ aa; ac ]) ] in Alcotest.check_tree_lwt "Empty subtrees are pruned" ~expected:pruned - (Tree.to_concrete input >|= Tree.of_concrete) + (Tree.to_concrete input |> Tree.of_concrete) in let () = @@ -857,25 +860,25 @@ let test_of_concrete _ () = ignore (Tree.of_concrete (`Tree [ ("k", c "v1"); ("k", c "v2") ]))) in - Lwt.return_unit + () let suite = [ - Alcotest_lwt.test_case "bindings" `Quick test_bindings; - Alcotest_lwt.test_case "paginated bindings" `Quick test_paginated_bindings; - Alcotest_lwt.test_case "diff" `Quick test_diff; - Alcotest_lwt.test_case "empty" `Quick test_empty; - Alcotest_lwt.test_case "add" `Quick test_add; - Alcotest_lwt.test_case "remove" `Quick test_remove; - Alcotest_lwt.test_case "update" `Quick test_update; - Alcotest_lwt.test_case "clear" `Quick test_clear; - Alcotest_lwt.test_case "minimal_reads" `Quick test_minimal_reads; - Alcotest_lwt.test_case "fold" `Quick test_fold_force; - Alcotest_lwt.test_case "Broken.hashes" `Quick Broken.test_hashes; - Alcotest_lwt.test_case "Broken.trees" `Quick Broken.test_trees; - Alcotest_lwt.test_case "Broken.pruned_fold" `Quick Broken.test_pruned_fold; - Alcotest_lwt.test_case "kind of empty path" `Quick test_kind_empty_path; - Alcotest_lwt.test_case "generic equality" `Quick test_generic_equality; - Alcotest_lwt.test_case "is_empty" `Quick test_is_empty; - Alcotest_lwt.test_case "of_concrete" `Quick test_of_concrete; + Alcotest.test_case "bindings" `Quick test_bindings; + Alcotest.test_case "paginated bindings" `Quick test_paginated_bindings; + Alcotest.test_case "diff" `Quick test_diff; + Alcotest.test_case "empty" `Quick test_empty; + Alcotest.test_case "add" `Quick test_add; + Alcotest.test_case "remove" `Quick test_remove; + Alcotest.test_case "update" `Quick test_update; + Alcotest.test_case "clear" `Quick test_clear; + Alcotest.test_case "minimal_reads" `Quick test_minimal_reads; + Alcotest.test_case "fold" `Quick test_fold_force; + Alcotest.test_case "Broken.hashes" `Quick Broken.test_hashes; + Alcotest.test_case "Broken.trees" `Quick Broken.test_trees; + Alcotest.test_case "Broken.pruned_fold" `Quick Broken.test_pruned_fold; + Alcotest.test_case "kind of empty path" `Quick test_kind_empty_path; + Alcotest.test_case "generic equality" `Quick test_generic_equality; + Alcotest.test_case "is_empty" `Quick test_is_empty; + Alcotest.test_case "of_concrete" `Quick test_of_concrete; ] diff --git a/test/irmin/test_tree.mli b/test/irmin/test_tree.mli index 3258b5f81c..8d313cc416 100644 --- a/test/irmin/test_tree.mli +++ b/test/irmin/test_tree.mli @@ -14,4 +14,4 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -val suite : unit Alcotest_lwt.test_case list +val suite : unit Alcotest.test_case list From 63791455bc10f16d6fdc4e40914c5f65ac6e3ef1 Mon Sep 17 00:00:00 2001 From: Patrick Ferris Date: Sun, 5 Jun 2022 17:48:48 +0100 Subject: [PATCH 02/99] Restore Test_tree.clear tree size --- test/irmin/test_tree.ml | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/test/irmin/test_tree.ml b/test/irmin/test_tree.ml index c00316a492..2458ccf288 100644 --- a/test/irmin/test_tree.ml +++ b/test/irmin/test_tree.ml @@ -470,13 +470,11 @@ type path = Store.Path.t [@@deriving irmin ~pp ~equal] let test_clear () = (* 1. Build a tree *) - Eio.traceln "Clear 1"; - let size = 256 in + let size = 830829 in let t = List.init size string_of_int |> List.fold_left (fun acc i -> Tree.add acc [ i ] i) (Tree.empty ()) in - Eio.traceln "Clear 2"; (* Check the state of the root and root/42 *) Alcotest.(check inspect) "Before clear, root" (`Node `Map) (Tree.inspect t); let () = @@ -485,19 +483,15 @@ let test_clear () = "Before clear, root node is eagerly evaluated" { nodes = 1; leafs = size; skips = 0; depth = 1; width = size } in - Eio.traceln "Clear 3"; let entry42 = Tree.find_tree t [ "42" ] |> Option.get in Alcotest.(check inspect) "Before clear, root/42" `Contents (Tree.inspect entry42); - Eio.traceln "Clear 4"; let () = let dont_skip k = Alcotest.failf "should not have skipped %a" pp_path k in Tree.fold ~force:(`False dont_skip) entry42 () in (* 2. Clear on non-persisted *) - Eio.traceln "Clear 5"; Tree.clear t; - Eio.traceln "Clear 6"; (* The state of the tree shouldn't have changed after this clear *) Alcotest.(check inspect) "Before persist" (`Node `Map) (Tree.inspect t); let () = From 4bc33c4187360db4bb07493fd8d9f2b9cbb1837d Mon Sep 17 00:00:00 2001 From: Patrick Ferris Date: Sun, 5 Jun 2022 22:45:56 +0100 Subject: [PATCH 03/99] Fix map_p, filter_map_p and convert irmin-fs --- dune | 2 +- src/irmin-fs/dune | 2 +- src/irmin-fs/irmin_fs.ml | 106 ++++++++++++++++++------------------- src/irmin-fs/irmin_fs.mli | 16 +++--- src/irmin-test/common.ml | 5 +- src/irmin-test/store.ml | 11 ++-- src/irmin/import.ml | 10 ++++ src/irmin/merge.ml | 13 ++--- src/irmin/object_graph.ml | 2 +- src/irmin/slice.ml | 6 +-- src/irmin/store.ml | 19 +++++-- src/irmin/tree.ml | 2 +- src/irmin/watch.ml | 6 ++- src/irmin/watch_intf.ml | 3 ++ test/irmin-fs/dune | 4 +- test/irmin-fs/test.ml | 3 +- test/irmin-fs/test_fs.ml | 9 ++-- test/irmin-mem/dune | 4 +- test/irmin-mem/test.ml | 3 +- test/irmin-mem/test_mem.ml | 2 +- 20 files changed, 129 insertions(+), 99 deletions(-) diff --git a/dune b/dune index fe7d302bca..612d291fc9 100644 --- a/dune +++ b/dune @@ -1,4 +1,4 @@ -(vendored_dirs vendors) +(vendored_dirs vendors irmin-watcher) (mdx (files README.md) diff --git a/src/irmin-fs/dune b/src/irmin-fs/dune index abe176afd4..e3ad30ba5e 100644 --- a/src/irmin-fs/dune +++ b/src/irmin-fs/dune @@ -1,7 +1,7 @@ (library (name irmin_fs) (public_name irmin-fs) - (libraries astring irmin logs lwt) + (libraries astring irmin logs) (preprocess (pps ppx_irmin.internal)) (instrumentation diff --git a/src/irmin-fs/irmin_fs.ml b/src/irmin-fs/irmin_fs.ml index b3d989ea17..01965b3862 100644 --- a/src/irmin-fs/irmin_fs.ml +++ b/src/irmin-fs/irmin_fs.ml @@ -32,15 +32,15 @@ end module type IO = sig type path = string - val rec_files : path -> string list Lwt.t - val file_exists : path -> bool Lwt.t - val read_file : path -> string option Lwt.t - val mkdir : path -> unit Lwt.t + val rec_files : path -> string list + val file_exists : path -> bool + val read_file : path -> string option + val mkdir : path -> unit type lock val lock_file : string -> lock - val write_file : ?temp_dir:path -> ?lock:lock -> path -> string -> unit Lwt.t + val write_file : ?temp_dir:path -> ?lock:lock -> path -> string -> unit val test_and_set_file : ?temp_dir:path -> @@ -48,9 +48,9 @@ module type IO = sig string -> test:string option -> set:string option -> - bool Lwt.t + bool - val remove_file : ?lock:lock -> path -> unit Lwt.t + val remove_file : ?lock:lock -> path -> unit end (* ~path *) @@ -81,9 +81,10 @@ struct let v config = let path = get_path config in - IO.mkdir path >|= fun () -> { path } + IO.mkdir path; + { path } - let close _ = Lwt.return_unit + let close _ = () let cast t = (t :> read_write t) let batch t f = f (cast t) @@ -110,13 +111,13 @@ struct let find t key = [%log.debug "find %a" pp_key key]; - IO.read_file (file_of_key t key) >|= function + match IO.read_file (file_of_key t key) with | None -> None | Some x -> value x let list t = [%log.debug "list"]; - let+ files = IO.rec_files (S.dir t.path) in + let files = IO.rec_files (S.dir t.path) in let files = let p = String.length t.path in List.fold_left @@ -153,8 +154,8 @@ struct [%log.debug "add %a" pp_key key]; let file = file_of_key t key in let temp_dir = temp_dir t in - IO.file_exists file >>= function - | true -> Lwt.return_unit + match IO.file_exists file with + | true -> () | false -> let str = to_bin_string value in IO.write_file ~temp_dir file str @@ -172,7 +173,7 @@ struct type t = { t : unit RO.t; w : W.t } type key = RO.key type value = RO.value - type watch = W.watch * (unit -> unit Lwt.t) + type watch = W.watch * (unit -> unit) let temp_dir t = t.t.RO.path / "tmp" @@ -186,7 +187,7 @@ struct let watches = E.create 10 let v config = - let+ t = RO.v config in + let t = RO.v config in let w = let path = RO.get_path config in try E.find watches path @@ -197,7 +198,10 @@ struct in { t; w } - let close t = W.clear t.w >>= fun () -> RO.close t.t + let close t = + W.clear t.w; + RO.close t.t + let find t = RO.find t.t let mem t = RO.mem t.t let list t = RO.list t.t @@ -214,16 +218,19 @@ struct W.listen_dir t.w dir ~key ~value:(RO.find t.t) let watch_key t key ?init f = - let* stop = listen_dir t in - let+ w = W.watch_key t.w key ?init f in + let stop = listen_dir t in + let w = W.watch_key t.w key ?init f in (w, stop) let watch t ?init f = - let* stop = listen_dir t in - let+ w = W.watch t.w ?init f in + let stop = listen_dir t in + let w = W.watch t.w ?init f in (w, stop) - let unwatch t (id, stop) = stop () >>= fun () -> W.unwatch t.w id + let unwatch t (id, stop) = + stop (); + W.unwatch t.w id + let raw_value = Irmin.Type.(unstage (to_bin_string V.t)) let set t key value = @@ -231,14 +238,14 @@ struct let temp_dir = temp_dir t in let file = RO.file_of_key t.t key in let lock = RO.lock_of_key t.t key in - IO.write_file ~temp_dir file ~lock (raw_value value) >>= fun () -> + IO.write_file ~temp_dir file ~lock (raw_value value); W.notify t.w key (Some value) let remove t key = [%log.debug "remove %a" RO.pp_key key]; let file = RO.file_of_key t.t key in let lock = RO.lock_of_key t.t key in - let* () = IO.remove_file ~lock file in + let () = IO.remove_file ~lock file in W.notify t.w key None let test_and_set t key ~test ~set = @@ -247,19 +254,19 @@ struct let file = RO.file_of_key t.t key in let lock = RO.lock_of_key t.t key in let raw_value = function None -> None | Some v -> Some (raw_value v) in - let* b = + let b = IO.test_and_set_file file ~temp_dir ~lock ~test:(raw_value test) ~set:(raw_value set) in - let+ () = if b then W.notify t.w key set else Lwt.return_unit in + let () = if b then W.notify t.w key set in b let clear t = [%log.debug "clear"]; - let remove_file key = + let remove_file key () = IO.remove_file ~lock:(RO.lock_of_key t.t key) (RO.file_of_key t.t key) in - list t >>= Lwt_list.iter_p remove_file + list t |> fun keys -> Eio.Fiber.all (List.map remove_file keys) end module Maker_ext (IO : IO) (Obj : Config) (Ref : Config) = struct @@ -320,70 +327,60 @@ end module IO_mem = struct type t = { - watches : (string, string -> unit Lwt.t) Hashtbl.t; + watches : (string, string -> unit) Hashtbl.t; files : (string, string) Hashtbl.t; } let t = { watches = Hashtbl.create 3; files = Hashtbl.create 13 } type path = string - type lock = Lwt_mutex.t + type lock = Eio.Mutex.t let locks = Hashtbl.create 10 let lock_file file = try Hashtbl.find locks file with Not_found -> - let l = Lwt_mutex.create () in + let l = Eio.Mutex.create () in Hashtbl.add locks file l; l let with_lock l f = - match l with None -> f () | Some l -> Lwt_mutex.with_lock l f + match l with None -> f () | Some l -> Eio.Mutex.with_lock l f let set_listen_hook () = let h _ dir f = Hashtbl.replace t.watches dir f; - Lwt.return (fun () -> - Hashtbl.remove t.watches dir; - Lwt.return_unit) + fun () -> Hashtbl.remove t.watches dir in Irmin.Backend.Watch.set_listen_dir_hook h let notify file = - Hashtbl.fold - (fun dir f acc -> - if String.is_prefix ~affix:dir file then f file :: acc else acc) - t.watches [] - |> Lwt_list.iter_p (fun x -> x) + Hashtbl.iter + (fun dir f -> if String.is_prefix ~affix:dir file then f file) + t.watches + (* |> Eio.Fiber.all *) - let mkdir _ = Lwt.return_unit + let mkdir _ = () let remove_file ?lock file = - with_lock lock (fun () -> - Hashtbl.remove t.files file; - Lwt.return_unit) + with_lock lock (fun () -> Hashtbl.remove t.files file) let rec_files dir = Hashtbl.fold (fun k _ acc -> if String.is_prefix ~affix:dir k then k :: acc else acc) t.files [] - |> Lwt.return - let file_exists file = Hashtbl.mem t.files file |> Lwt.return + let file_exists file = Hashtbl.mem t.files file let read_file file = try let buf = Hashtbl.find t.files file in - Lwt.return_some buf - with Not_found -> Lwt.return_none + Some buf + with Not_found -> None let write_file ?temp_dir:_ ?lock file v = - let* () = - with_lock lock (fun () -> - Hashtbl.replace t.files file v; - Lwt.return_unit) - in + let () = with_lock lock (fun () -> Hashtbl.replace t.files file v) in notify file let equal x y = @@ -406,15 +403,14 @@ module IO_mem = struct Hashtbl.replace t.files file v; true in - let+ () = if b then notify file else Lwt.return_unit in + let () = if b then notify file in b in with_lock (Some lock) f let clear () = Hashtbl.clear t.files; - Hashtbl.clear t.watches; - Lwt.return_unit + Hashtbl.clear t.watches end (* Enforce that {!S} is a sub-type of {!Irmin.Maker}. *) diff --git a/src/irmin-fs/irmin_fs.mli b/src/irmin-fs/irmin_fs.mli index cebbd10c1b..c933667e5f 100644 --- a/src/irmin-fs/irmin_fs.mli +++ b/src/irmin-fs/irmin_fs.mli @@ -38,19 +38,19 @@ module type IO = sig (** {2 Read operations} *) - val rec_files : path -> string list Lwt.t + val rec_files : path -> string list (** [rec_files dir] is the list of files recursively present in [dir] and all of its sub-directories. Return filenames prefixed by [dir]. *) - val file_exists : path -> bool Lwt.t + val file_exists : path -> bool (** [file_exist f] is true if [f] exists. *) - val read_file : path -> string option Lwt.t + val read_file : path -> string option (** Read the contents of a file using mmap. *) (** {2 Write Operations} *) - val mkdir : path -> unit Lwt.t + val mkdir : path -> unit (** Create a directory. *) type lock @@ -59,7 +59,7 @@ module type IO = sig val lock_file : path -> lock (** [lock_file f] is the lock associated to the file [f]. *) - val write_file : ?temp_dir:path -> ?lock:lock -> path -> string -> unit Lwt.t + val write_file : ?temp_dir:path -> ?lock:lock -> path -> string -> unit (** Atomic writes. *) val test_and_set_file : @@ -68,10 +68,10 @@ module type IO = sig path -> test:string option -> set:string option -> - bool Lwt.t + bool (** Test and set. *) - val remove_file : ?lock:lock -> path -> unit Lwt.t + val remove_file : ?lock:lock -> path -> unit (** Remove a file or directory (even if non-empty). *) end @@ -104,6 +104,6 @@ module Maker_ext (IO : IO) (Obj : Config) (Ref : Config) : Irmin.Maker module IO_mem : sig include IO - val clear : unit -> unit Lwt.t + val clear : unit -> unit val set_listen_hook : unit -> unit end diff --git a/src/irmin-test/common.ml b/src/irmin-test/common.ml index 154cd781c9..6465908d3d 100644 --- a/src/irmin-test/common.ml +++ b/src/irmin-test/common.ml @@ -100,7 +100,10 @@ module Suite = struct in let repo = Store.Repo.v config in let branches = Store.Repo.branches repo in - let () = List.iter (Store.Branch.remove repo) branches in + let () = + List.map (fun br () -> Store.Branch.remove repo br) branches + |> Eio.Fiber.all + in Store.Repo.close repo let create ~name ?(init = fun ~config:_ -> ()) ?clean ~config ~store ?stats diff --git a/src/irmin-test/store.ml b/src/irmin-test/store.ml index a4b114282f..f57bb8176b 100644 --- a/src/irmin-test/store.ml +++ b/src/irmin-test/store.ml @@ -46,28 +46,33 @@ module Make (S : Generic_key) = struct let old k () = Ok (Some k) let may repo commits = function None -> () | Some f -> f repo commits + let map_p xs = + Eio.Switch.run @@ fun sw -> List.map (Eio.Fiber.fork_promise ~sw) xs + let may_get_keys repo keys = function | None -> () | Some f -> let commits = List.map - (fun key -> + (fun key () -> S.Commit.of_key repo key |> function | None -> Alcotest.fail "Cannot read commit hash" | Some c -> c) keys + |> map_p in f repo commits let may_with_branch branches repo hook = let heads = List.map - (fun branch -> + (fun branch () -> let h = S.Head.find branch in match h with | None -> Alcotest.fail "Cannot read head" | Some head -> head) branches + |> map_p in may repo heads hook @@ -2455,4 +2460,4 @@ let run name ?(slow = false) ?random_seed ~sleep ~misc tl = (* Ensure that failures occuring in async lwt threads are raised. *) let tl1 = List.map (suite sleep) tl in let tl1 = if slow then tl1 @ List.map slow_suite tl else tl1 in - Alcotest.run name (misc @ tl1) + Alcotest.run ~bail:true name (misc @ tl1) diff --git a/src/irmin/import.ml b/src/irmin/import.ml index a5e2e3b39b..2c4744ce50 100644 --- a/src/irmin/import.ml +++ b/src/irmin/import.ml @@ -23,6 +23,16 @@ type read_write = Perms.read_write (** {2 Dependency extensions} *) +module Fiber = struct + include Eio.Fiber + (** @closed *) + + let all_p fs = + Eio.Switch.run @@ fun sw -> + let ps = List.map (fork_promise ~sw) fs in + List.map Eio.Promise.await_exn ps +end + module Option = struct include Option (** @closed *) diff --git a/src/irmin/merge.ml b/src/irmin/merge.ml index 6329aeddd5..8d29f068f6 100644 --- a/src/irmin/merge.ml +++ b/src/irmin/merge.ml @@ -208,8 +208,10 @@ let alist_iter2 compare_k f l1 l2 = (* assume l1 and l2 are key-sorted *) let alist_iter2_lwt compare_k f l1 l2 = let l3 = ref [] in - alist_iter2 compare_k (fun left right -> l3 := f left right :: !l3) l1 l2; - List.iter Fun.id (List.rev !l3) + alist_iter2 compare_k + (fun left right -> l3 := (fun () -> f left right) :: !l3) + l1 l2; + Eio.Fiber.all (List.rev !l3) (* DO NOT assume l1 and l2 are key-sorted *) let alist_merge_lwt compare_k f l1 l2 = @@ -316,13 +318,12 @@ struct let iter2 f m1 m2 = let m3 = ref [] in - iter2 (fun key data -> m3 := f key data :: !m3) m1 m2; - (* Check iter_p *) - List.iter (fun b -> b ()) (List.rev !m3) + iter2 (fun key data -> m3 := (fun () -> f key data) :: !m3) m1 m2; + Eio.Fiber.all (List.rev !m3) let merge_maps f m1 m2 = let l3 = ref [] in - let f key data () = + let f key data = match f key data with None -> () | Some v -> l3 := (key, v) :: !l3 in iter2 f m1 m2; diff --git a/src/irmin/object_graph.ml b/src/irmin/object_graph.ml index b3005d9b84..63d2ef5cb0 100644 --- a/src/irmin/object_graph.ml +++ b/src/irmin/object_graph.ml @@ -136,7 +136,7 @@ struct | None -> () | Some edge -> let keys = pred key in - List.iter (fun k -> edge key k) keys + List.map (fun k () -> edge key k) keys |> Eio.Fiber.all else () in let visit_predecessors ~filter_history key level = diff --git a/src/irmin/slice.ml b/src/irmin/slice.ml index ada639d4b6..5b44d2136c 100644 --- a/src/irmin/slice.ml +++ b/src/irmin/slice.ml @@ -43,7 +43,7 @@ struct | `Commit c -> t.commits <- c :: t.commits let iter t f = - List.iter (fun c -> f (`Contents c)) t.contents; - List.iter (fun n -> f (`Node n)) t.nodes; - List.iter (fun c -> f (`Commit c)) t.commits + List.map (fun c () -> f (`Contents c)) t.contents |> Eio.Fiber.all; + List.map (fun n () -> f (`Node n)) t.nodes |> Eio.Fiber.all; + List.map (fun c () -> f (`Commit c)) t.commits |> Eio.Fiber.all end diff --git a/src/irmin/store.ml b/src/irmin/store.ml index b47f34b7d0..a224c41449 100644 --- a/src/irmin/store.ml +++ b/src/irmin/store.ml @@ -980,7 +980,11 @@ module Make (B : Backend.S) = struct let return_lcas r = function | Error _ as e -> e - | Ok commits -> List.filter_map (Commit.of_key r) commits |> Result.ok + | Ok commits -> + List.map (fun v () -> Commit.of_key r v) commits + |> Fiber.all_p + |> List.filter_map (fun v -> v) + |> Result.ok let lcas ?max_depth ?n t1 t2 = let h1 = Head.get t1 in @@ -1070,8 +1074,11 @@ module Make (B : Backend.S) = struct [%log.debug "history"]; let pred = function | `Commit k -> - Commits.parents (commit_store t) k - |> List.filter_map (Commit.of_key t.repo) + List.map + (fun v () -> Commit.of_key t.repo v) + (Commits.parents (commit_store t) k) + |> Fiber.all_p + |> List.filter_map (fun v -> v) |> fun parents -> List.map (fun x -> `Commit x.key) parents | _ -> [] in @@ -1118,8 +1125,8 @@ module Make (B : Backend.S) = struct | None -> false in let found = - List.for_all - (fun hash -> + List.map + (fun hash () -> match Commit.of_key repo hash with | Some commit -> ( let () = @@ -1135,6 +1142,8 @@ module Make (B : Backend.S) = struct | _, _ -> false) | None -> false) parents + |> Fiber.all_p + |> List.for_all Fun.id in if found then search (current :: acc) else search acc in diff --git a/src/irmin/tree.ml b/src/irmin/tree.ml index 0c7fd9c476..902ef2f832 100644 --- a/src/irmin/tree.ml +++ b/src/irmin/tree.ml @@ -53,7 +53,7 @@ let alist_iter2 compare_k f l1 l2 = let alist_iter2_lwt compare_k f l1 l2 = let l3 = ref [] in alist_iter2 compare_k (fun left right -> l3 := f left right :: !l3) l1 l2; - List.iter (fun b -> b ()) (List.rev !l3) + Eio.Fiber.all (List.rev !l3) exception Backend_invariant_violation of string exception Assertion_failure of string diff --git a/src/irmin/watch.ml b/src/irmin/watch.ml index 5abfc4eed4..17de6cdbcc 100644 --- a/src/irmin/watch.ml +++ b/src/irmin/watch.ml @@ -26,10 +26,12 @@ let none _ _ = assert false let listen_dir_hook = ref none +let watch_switch = ref None type hook = int -> string -> (string -> unit) -> unit -> unit let set_listen_dir_hook (h : hook) = listen_dir_hook := h +let set_watch_switch sw = watch_switch := Some sw let id () = let c = ref 0 in @@ -59,8 +61,8 @@ let scheduler () = (s, Eio.Stream.add s) in incr workers_r; - ( Eio.Switch.run @@ fun sw -> - Eio.Fiber.fork ~sw @@ fun () -> stream_iter (fun f -> f ()) stream ); + let sw = Option.get !watch_switch in + (Eio.Fiber.fork ~sw @@ fun () -> stream_iter (fun f -> f ()) stream); (* Lwt.async (fun () -> (* FIXME: we would like to skip some updates if more recent ones are at the back of the queue. *) diff --git a/src/irmin/watch_intf.ml b/src/irmin/watch_intf.ml index 560f9b98bb..5ac0d75fd5 100644 --- a/src/irmin/watch_intf.ml +++ b/src/irmin/watch_intf.ml @@ -81,6 +81,9 @@ module type Sigs = sig val none : hook (** [none] is the hooks which asserts false. *) + val set_watch_switch : Eio.Switch.t -> unit + (** A terrible hack that will need fixed... *) + val set_listen_dir_hook : hook -> unit (** Register a function which looks for file changes in a directory and return a function to stop watching. It is probably best to use diff --git a/test/irmin-fs/dune b/test/irmin-fs/dune index 87614dbcb5..e3a5030907 100644 --- a/test/irmin-fs/dune +++ b/test/irmin-fs/dune @@ -1,12 +1,12 @@ (library (name test_fs) (modules test_fs) - (libraries irmin-fs irmin-test lwt)) + (libraries irmin-fs irmin-test)) (library (name test_fs_unix) (modules test_fs_unix) - (libraries test_fs irmin irmin-fs.unix irmin-test irmin-watcher lwt)) + (libraries test_fs irmin irmin-fs.unix irmin-test irmin-watcher)) (executable (name test) diff --git a/test/irmin-fs/test.ml b/test/irmin-fs/test.ml index 2ab8c18fce..0cd0c50763 100644 --- a/test/irmin-fs/test.ml +++ b/test/irmin-fs/test.ml @@ -15,6 +15,5 @@ *) let () = - Lwt_main.run - @@ Irmin_test.Store.run "irmin-fs" ~slow:true ~misc:[] ~sleep:Lwt_unix.sleep + Irmin_test.Store.run "irmin-fs" ~slow:true ~misc:[] ~sleep:Eio_unix.sleep [ (`Quick, Test_fs.suite) ] diff --git a/test/irmin-fs/test_fs.ml b/test/irmin-fs/test_fs.ml index f87198ac92..5985f37469 100644 --- a/test/irmin-fs/test_fs.ml +++ b/test/irmin-fs/test_fs.ml @@ -14,13 +14,16 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Lwt.Infix module IO = Irmin_fs.IO_mem let test_db = Filename.concat "_build" "test-db" -let init ~config:_ = IO.clear () >|= fun () -> IO.set_listen_hook () + +let init ~config:_ = + IO.clear (); + IO.set_listen_hook () + let config = Irmin_fs.config test_db -let clean ~config:_ = Lwt.return_unit +let clean ~config:_ = () let store = Irmin_test.store (module Irmin_fs.Maker (IO)) (module Irmin.Metadata.None) diff --git a/test/irmin-mem/dune b/test/irmin-mem/dune index 1f548b95c1..4380ac8b1d 100644 --- a/test/irmin-mem/dune +++ b/test/irmin-mem/dune @@ -1,12 +1,12 @@ (library (name test_mem) (modules test_mem) - (libraries irmin irmin-test irmin.mem lwt)) + (libraries irmin irmin-test irmin.mem)) (executable (name test) (modules test) - (libraries alcotest lwt.unix irmin-test test_mem)) + (libraries alcotest eio_main irmin-test test_mem)) (rule (alias runtest) diff --git a/test/irmin-mem/test.ml b/test/irmin-mem/test.ml index e2d99e032f..fde07895fc 100644 --- a/test/irmin-mem/test.ml +++ b/test/irmin-mem/test.ml @@ -15,6 +15,5 @@ *) let () = - Lwt_main.run - @@ Irmin_test.Store.run "irmin-mem" ~slow:true ~misc:[] ~sleep:Lwt_unix.sleep + Irmin_test.Store.run "irmin-mem" ~slow:true ~misc:[] ~sleep:Eio_unix.sleep [ (`Quick, Test_mem.suite) ] diff --git a/test/irmin-mem/test_mem.ml b/test/irmin-mem/test_mem.ml index bf8c5b13cd..6287377522 100644 --- a/test/irmin-mem/test_mem.ml +++ b/test/irmin-mem/test_mem.ml @@ -16,5 +16,5 @@ let store = Irmin_test.store (module Irmin_mem) (module Irmin.Metadata.None) let config = Irmin_mem.config () -let init ~config:_ = Lwt.return_unit +let init ~config:_ = () let suite = Irmin_test.Suite.create ~name:"MEM" ~init ~store ~config () From 9bc6ab8359dc5f8fdcc911f8b065214d8caaf1e4 Mon Sep 17 00:00:00 2001 From: Patrick Ferris Date: Sun, 5 Jun 2022 23:12:01 +0100 Subject: [PATCH 04/99] Add eio to opam file --- irmin.opam | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/irmin.opam b/irmin.opam index f5521eb51e..a9cd88e61e 100644 --- a/irmin.opam +++ b/irmin.opam @@ -21,7 +21,7 @@ depends: [ "uri" {>= "1.3.12"} "uutf" "jsonm" {>= "1.0.0"} - "lwt" {>= "5.3.0"} + "eio" {>= "0.2"} "digestif" {>= "0.9.0"} "ocamlgraph" "logs" {>= "0.5.0"} @@ -32,6 +32,7 @@ depends: [ "ppx_irmin" {= version} "hex" {with-test} "alcotest" {>= "1.1.0" & with-test} + "eio_main" {>= "0.2" & with-test} "alcotest-lwt" {with-test} "qcheck-alcotest" {with-test} "vector" {with-test} @@ -39,6 +40,10 @@ depends: [ "bisect_ppx" {dev & >= "2.5.0"} ] +pin-depends: [ + [ "eio.0.2" "git+https://github.com/TheLortex/eio#d2f0cfc08e1d9859fb56c09cb04b49bced602400" ] +] + conflicts: [ "result" {< "1.5"} # Requires `Result = Stdlib.Result` ] From cfc7fafa3d80f4a419372a3d1aeaa2b2cc4d6d60 Mon Sep 17 00:00:00 2001 From: Patrick Ferris Date: Mon, 6 Jun 2022 00:28:05 +0100 Subject: [PATCH 05/99] Convert irmin-pack to direct-style --- src/irmin-pack/atomic_write_intf.ml | 2 +- src/irmin-pack/dune | 2 +- src/irmin-pack/indexable_intf.ml | 4 +- src/irmin-pack/inode.ml | 18 +- src/irmin-pack/inode_intf.ml | 2 +- src/irmin-pack/mem/indexable.ml | 17 +- src/irmin-pack/mem/indexable.mli | 2 +- src/irmin-pack/mem/irmin_pack_mem.ml | 18 +- src/irmin-pack/unix/async.ml | 20 +- src/irmin-pack/unix/async_intf.ml | 2 +- src/irmin-pack/unix/atomic_write.ml | 28 +- src/irmin-pack/unix/checks.ml | 64 +- src/irmin-pack/unix/checks_intf.ml | 34 +- src/irmin-pack/unix/dune | 3 +- src/irmin-pack/unix/gc.ml | 28 +- src/irmin-pack/unix/gc.mli | 5 +- src/irmin-pack/unix/gc_args.ml | 2 +- src/irmin-pack/unix/inode_intf.ml | 2 +- src/irmin-pack/unix/pack_store.ml | 20 +- src/irmin-pack/unix/snapshot.ml | 22 +- src/irmin-pack/unix/snapshot_intf.ml | 10 +- src/irmin-pack/unix/store.ml | 95 +- src/irmin-pack/unix/store_intf.ml | 23 +- src/irmin-test/store.ml | 18 +- src/irmin/watch_intf.ml | 2 +- test/irmin-pack/common.ml | 28 +- test/irmin-pack/common.mli | 14 +- test/irmin-pack/dune | 4 +- test/irmin-pack/test.ml | 6 +- test/irmin-pack/test_corrupted.ml | 23 +- test/irmin-pack/test_corrupted.mli | 2 +- test/irmin-pack/test_dispatcher.ml | 25 +- test/irmin-pack/test_dispatcher.mli | 2 +- test/irmin-pack/test_existing_stores.ml | 78 +- test/irmin-pack/test_existing_stores.mli | 2 +- test/irmin-pack/test_flush_reload.ml | 70 +- test/irmin-pack/test_gc.ml | 1171 ++++++++++---------- test/irmin-pack/test_gc.mli | 24 +- test/irmin-pack/test_hashes.ml | 49 +- test/irmin-pack/test_hashes.mli | 2 +- test/irmin-pack/test_inode.ml | 105 +- test/irmin-pack/test_inode.mli | 2 +- test/irmin-pack/test_mapping.ml | 7 +- test/irmin-pack/test_mapping.mli | 2 +- test/irmin-pack/test_nearest_leq.ml | 27 + test/irmin-pack/test_nearest_leq.mli | 2 +- test/irmin-pack/test_pack.ml | 243 ++-- test/irmin-pack/test_pack.mli | 2 +- test/irmin-pack/test_pack_version_bump.ml | 24 +- test/irmin-pack/test_pack_version_bump.mli | 2 +- test/irmin-pack/test_readonly.ml | 72 +- test/irmin-pack/test_readonly.mli | 2 +- test/irmin-pack/test_snapshot.ml | 105 +- test/irmin-pack/test_tree.ml | 217 ++-- test/irmin-pack/test_upgrade.ml | 199 ++-- 55 files changed, 1442 insertions(+), 1512 deletions(-) create mode 100644 test/irmin-pack/test_nearest_leq.ml diff --git a/src/irmin-pack/atomic_write_intf.ml b/src/irmin-pack/atomic_write_intf.ml index 96b35e0542..bf9ca4db11 100644 --- a/src/irmin-pack/atomic_write_intf.ml +++ b/src/irmin-pack/atomic_write_intf.ml @@ -23,7 +23,7 @@ end module type Persistent = sig include S - val v : ?fresh:bool -> ?readonly:bool -> string -> t Lwt.t + val v : ?fresh:bool -> ?readonly:bool -> string -> t end module type Value = sig diff --git a/src/irmin-pack/dune b/src/irmin-pack/dune index e62d63c724..6eba1b28f3 100644 --- a/src/irmin-pack/dune +++ b/src/irmin-pack/dune @@ -1,7 +1,7 @@ (library (public_name irmin-pack) (name irmin_pack) - (libraries fmt irmin irmin.data logs lwt optint) + (libraries fmt irmin irmin.data logs optint) (preprocess (pps ppx_irmin.internal)) (instrumentation diff --git a/src/irmin-pack/indexable_intf.ml b/src/irmin-pack/indexable_intf.ml index 6a3211debf..1abcbc4b00 100644 --- a/src/irmin-pack/indexable_intf.ml +++ b/src/irmin-pack/indexable_intf.ml @@ -19,10 +19,10 @@ open! Import module type S = sig include Irmin.Indexable.S - val add : 'a t -> value -> key Lwt.t + val add : 'a t -> value -> key (** Overwrite [add] to work with a read-only database handler. *) - val unsafe_add : 'a t -> hash -> value -> key Lwt.t + val unsafe_add : 'a t -> hash -> value -> key (** Overwrite [unsafe_add] to work with a read-only database handler. *) val index_direct : _ t -> hash -> key option diff --git a/src/irmin-pack/inode.ml b/src/irmin-pack/inode.ml index 4e314934a2..64723f4746 100644 --- a/src/irmin-pack/inode.ml +++ b/src/irmin-pack/inode.ml @@ -2373,7 +2373,7 @@ struct let v = Val.of_raw find v in Some v - let find t k = unsafe_find ~check_integrity:true t k |> Lwt.return + let find t k = unsafe_find ~check_integrity:true t k let save ?allow_non_root t v = let add k v = @@ -2383,7 +2383,7 @@ struct ~mem:(Pack.unsafe_mem t) v let hash_exn = Val.hash_exn - let add t v = Lwt.return (save t v) + let add t v = save t v let equal_hash = Irmin.Type.(unstage (equal H.t)) let check_hash expected got = @@ -2394,22 +2394,22 @@ struct let unsafe_add t k v = check_hash k (hash_exn v); - Lwt.return (save t v) + save t v let batch = Pack.batch let close = Pack.close let decode_bin_length = Inter.Raw.decode_bin_length let protect_from_invalid_depth_exn f = - Lwt.catch f (function - | Invalid_depth { expected; got; v } -> - let msg = Fmt.to_to_string pp_invalid_depth (expected, got, v) in - Lwt.return (Error msg) - | e -> Lwt.fail e) + try f () with + | Invalid_depth { expected; got; v } -> + let msg = Fmt.to_to_string pp_invalid_depth (expected, got, v) in + Error msg + | e -> raise e let integrity_check_inodes t k = protect_from_invalid_depth_exn @@ fun () -> - find t k >|= function + match find t k with | None -> (* we are traversing the node graph, should find all values *) assert false diff --git a/src/irmin-pack/inode_intf.ml b/src/irmin-pack/inode_intf.ml index bff9e0ae0e..4aac521a12 100644 --- a/src/irmin-pack/inode_intf.ml +++ b/src/irmin-pack/inode_intf.ml @@ -98,7 +98,7 @@ module type S = sig and type Portable.hash := hash val decode_bin_length : string -> int -> int - val integrity_check_inodes : [ `Read ] t -> key -> (unit, string) result Lwt.t + val integrity_check_inodes : [ `Read ] t -> key -> (unit, string) result val save : ?allow_non_root:bool -> 'a t -> value -> key end diff --git a/src/irmin-pack/mem/indexable.ml b/src/irmin-pack/mem/indexable.ml index 840e5e8268..15ed466637 100644 --- a/src/irmin-pack/mem/indexable.ml +++ b/src/irmin-pack/mem/indexable.ml @@ -76,15 +76,14 @@ module Maker (K : Irmin.Hash.S) = struct type 'a t = { name : string; mutable t : value KMap.t } let index_direct _ h = Some h - let index t h = Lwt.return (index_direct t h) + let index t h = index_direct t h let instances = Pool.create ~alloc:(fun name -> { name; t = KMap.empty }) - let v name = Lwt.return (Pool.take instances name) + let v name = Pool.take instances name let equal_key = Irmin.Type.(unstage (equal K.t)) let close t = [%log.debug "close"]; - Pool.drop instances t.name; - Lwt.return_unit + Pool.drop instances t.name let cast t = (t :> read_write t) let batch t f = f (cast t) @@ -111,16 +110,16 @@ module Maker (K : Irmin.Hash.S) = struct let find t k = [%log.debug "find %a" pp_hash k]; find t k |> function - | Ok r -> Lwt.return r + | Ok r -> r | Error (k, k') -> - Fmt.kstr Lwt.fail_invalid_arg "corrupted value: got %a, expecting %a" - pp_hash k' pp_hash k + Fmt.kstr invalid_arg "corrupted value: got %a, expecting %a" pp_hash + k' pp_hash k let unsafe_mem t k = [%log.debug "mem %a" pp_hash k]; KMap.mem k t.t - let mem t k = Lwt.return (unsafe_mem t k) + let mem t k = unsafe_mem t k let unsafe_append ~ensure_unique:_ ~overcommit:_ t k v = [%log.debug "add -> %a" pp_hash k]; @@ -128,7 +127,7 @@ module Maker (K : Irmin.Hash.S) = struct k let unsafe_add t k v = - Lwt.return (unsafe_append ~ensure_unique:true ~overcommit:true t k v) + unsafe_append ~ensure_unique:true ~overcommit:true t k v let add t v = unsafe_add t (Val.hash v) v end diff --git a/src/irmin-pack/mem/indexable.mli b/src/irmin-pack/mem/indexable.mli index 20ac827fc3..d96f2c981d 100644 --- a/src/irmin-pack/mem/indexable.mli +++ b/src/irmin-pack/mem/indexable.mli @@ -26,6 +26,6 @@ module Maker (K : Irmin.Hash.S) : sig and type key = K.t and type value = Val.t - val v : string -> read t Lwt.t + val v : string -> read t end end diff --git a/src/irmin-pack/mem/irmin_pack_mem.ml b/src/irmin-pack/mem/irmin_pack_mem.ml index 608a35fa1d..0a09d78b3c 100644 --- a/src/irmin-pack/mem/irmin_pack_mem.ml +++ b/src/irmin-pack/mem/irmin_pack_mem.ml @@ -34,7 +34,7 @@ struct module Indexable_mem = Pack.Make (Value) include Irmin_pack.Indexable.Closeable (Indexable_mem) - let v x = Indexable_mem.v x >|= make_closeable + let v x = Indexable_mem.v x |> make_closeable end module Maker (Config : Irmin_pack.Conf.S) = struct @@ -119,7 +119,7 @@ module Maker (Config : Irmin_pack.Conf.S) = struct module AW = Atomic_write (Key) (Val) include Irmin_pack.Atomic_write.Closeable (AW) - let v () = AW.v () >|= make_closeable + let v () = AW.v () |> make_closeable end module Slice = Irmin.Backend.Slice.Make (Contents) (Node) (Commit) @@ -151,16 +151,16 @@ module Maker (Config : Irmin_pack.Conf.S) = struct let v config = let root = Irmin_pack.Conf.root config in - let* contents = Contents.Indexable.v root in - let* node = Node.Indexable.v root in - let* commit = Commit.Indexable.v root in - let+ branch = Branch.v () in + let contents = Contents.Indexable.v root in + let node = Node.Indexable.v root in + let commit = Commit.Indexable.v root in + let branch = Branch.v () in { contents; node; commit; branch; config } let close t = - Contents.Indexable.close (contents_t t) >>= fun () -> - Node.Indexable.close (snd (node_t t)) >>= fun () -> - Commit.Indexable.close (snd (commit_t t)) >>= fun () -> + Contents.Indexable.close (contents_t t); + Node.Indexable.close (snd (node_t t)); + Commit.Indexable.close (snd (commit_t t)); Branch.close t.branch end end diff --git a/src/irmin-pack/unix/async.ml b/src/irmin-pack/unix/async.ml index 9585970374..103815411c 100644 --- a/src/irmin-pack/unix/async.ml +++ b/src/irmin-pack/unix/async.ml @@ -58,10 +58,10 @@ module Unix = struct let async f = Stdlib.flush_all (); - match Lwt_unix.fork () with + match Unix.fork () with | 0 -> - Lwt_main.Exit_hooks.remove_all (); - Lwt.abandon_paused (); + (* Lwt_main.Exit_hooks.remove_all (); + Lwt_main.abandon_yielded_and_paused (); *) let exit_code = match f () with | () -> Exit_code.success @@ -77,12 +77,12 @@ module Unix = struct { pid; status = `Running } let status_of_process_outcome = function - | Lwt_unix.WEXITED n when n = Exit_code.success -> `Success - | Lwt_unix.WEXITED n when n = Exit_code.unhandled_exn -> + | Unix.WEXITED n when n = Exit_code.success -> `Success + | Unix.WEXITED n when n = Exit_code.unhandled_exn -> `Failure "Unhandled exception" - | Lwt_unix.WSIGNALED n -> `Failure (Fmt.str "Signaled %d" n) - | Lwt_unix.WEXITED n -> `Failure (Fmt.str "Exited %d" n) - | Lwt_unix.WSTOPPED n -> `Failure (Fmt.str "Stopped %d" n) + | Unix.WSIGNALED n -> `Failure (Fmt.str "Signaled %d" n) + | Unix.WEXITED n -> `Failure (Fmt.str "Exited %d" n) + | Unix.WSTOPPED n -> `Failure (Fmt.str "Stopped %d" n) let cancel t = match t.status with @@ -112,10 +112,10 @@ module Unix = struct let await t = match t.status with | `Running -> - let+ pid, status = Lwt_unix.waitpid [] t.pid in + let pid, status = Unix.waitpid [] t.pid in let s = status_of_process_outcome status in Exit.remove pid; t.status <- s; s - | #outcome as s -> Lwt.return s + | #outcome as s -> s end diff --git a/src/irmin-pack/unix/async_intf.ml b/src/irmin-pack/unix/async_intf.ml index 03876a773a..97edfc7b20 100644 --- a/src/irmin-pack/unix/async_intf.ml +++ b/src/irmin-pack/unix/async_intf.ml @@ -28,7 +28,7 @@ module type S = sig val async : (unit -> unit) -> t (** Start a task. *) - val await : t -> [> outcome ] Lwt.t + val await : t -> [> outcome ] (** If running, wait for a task to finish and return its outcome. If not running, return the oucome of the task. *) diff --git a/src/irmin-pack/unix/atomic_write.ml b/src/irmin-pack/unix/atomic_write.ml index d625a4a7d1..378defb8d3 100644 --- a/src/irmin-pack/unix/atomic_write.ml +++ b/src/irmin-pack/unix/atomic_write.ml @@ -99,13 +99,13 @@ module Make_persistent (Io : Io.S) (K : Irmin.Type.S) (V : Value.S) = struct if Io.readonly t.block then sync_offset t; try Some (Tbl.find t.cache k) with Not_found -> None - let find t k = Lwt.return (unsafe_find t k) + let find t k = unsafe_find t k let unsafe_mem t k = [%log.debug "[branches] mem %a" pp_key k]; try Tbl.mem t.cache k with Not_found -> false - let mem t v = Lwt.return (unsafe_mem t v) + let mem t v = unsafe_mem t v let unsafe_remove t k = Tbl.remove t.cache k; @@ -140,7 +140,7 @@ module Make_persistent (Io : Io.S) (K : Irmin.Type.S) (V : Value.S) = struct let block_size = block_size block in let t = { cache; index; block; block_size; w = watches } in refill t ~to_:block_size ~from:(Int63.of_int dead_header_size); - Lwt.return t + t let clear _ = Fmt.failwith "Unsupported operation" @@ -164,23 +164,27 @@ module Make_persistent (Io : Io.S) (K : Irmin.Type.S) (V : Value.S) = struct let unsafe_test_and_set t k ~test ~set = let v = try Some (Tbl.find t.cache k) with Not_found -> None in - if not (equal_v_opt v test) then Lwt.return_false + if not (equal_v_opt v test) then false else - let return () = Lwt.return_true in match set with - | None -> unsafe_remove t k |> return - | Some v -> unsafe_set t k v |> return + | None -> + unsafe_remove t k; + true + | Some v -> + unsafe_set t k v; + true let test_and_set t k ~test ~set = [%log.debug "[branches] test-and-set %a" pp_key k]; - unsafe_test_and_set t k ~test ~set >>= function - | true -> W.notify t.w k set >|= fun () -> true - | false -> Lwt.return_false + match unsafe_test_and_set t k ~test ~set with + | true -> + W.notify t.w k set; + true + | false -> false let list t = [%log.debug "[branches] list"]; - let keys = Tbl.fold (fun k _ acc -> k :: acc) t.cache [] in - Lwt.return keys + Tbl.fold (fun k _ acc -> k :: acc) t.cache [] let watch_key t = W.watch_key t.w let watch t = W.watch t.w diff --git a/src/irmin-pack/unix/checks.ml b/src/irmin-pack/unix/checks.ml index 876a0cd1b1..5a923a09c2 100644 --- a/src/irmin-pack/unix/checks.ml +++ b/src/irmin-pack/unix/checks.ml @@ -106,11 +106,9 @@ module Make (Store : Store) = struct let log_size = conf root |> Conf.index_log_size in let objects = traverse_index ~root log_size in { hash_size = Bytes Hash.hash_size; log_size; objects } - |> Irmin.Type.pp_json ~minify:false t Fmt.stdout; - Lwt.return_unit + |> Irmin.Type.pp_json ~minify:false t Fmt.stdout - let term_internal = - Cmdliner.Term.(const (fun root () -> Lwt_main.run (run ~root)) $ path) + let term_internal = Cmdliner.Term.(const (fun root () -> run ~root) $ path) let term = let doc = "Print high-level statistics about the store." in @@ -213,20 +211,20 @@ module Make (Store : Store) = struct let run ?ppf ~root ~auto_repair ~always ~heads () = let conf = conf root always in - let* repo = Store.Repo.v conf in - let* heads = + let repo = Store.Repo.v conf in + let heads = match heads with | None -> Store.Repo.heads repo | Some heads -> - Lwt_list.filter_map_s + List.filter_map (fun x -> match Repr.of_string Store.Hash.t x with | Ok x -> Store.Commit.of_hash repo x - | Error (`Msg m) -> Fmt.kstr Lwt.fail_with "Invalid hash %S" m) + | Error (`Msg m) -> Fmt.kstr failwith "Invalid hash %S" m) heads in - let* result = Store.integrity_check ?ppf ~auto_repair ~heads repo in - let+ () = Store.Repo.close repo in + let result = Store.integrity_check ?ppf ~auto_repair ~heads repo in + let () = Store.Repo.close repo in handle_result ?ppf ?name:None result let heads = @@ -246,9 +244,8 @@ module Make (Store : Store) = struct let term_internal = Cmdliner.Term.( const (fun root auto_repair always heads () -> - Lwt_main.run - (run ~ppf:Format.err_formatter ~root ~auto_repair ~always ~heads - ())) + run ~ppf:Format.err_formatter ~root ~auto_repair ~always ~heads + ()) $ path $ auto_repair $ always @@ -271,20 +268,20 @@ module Make (Store : Store) = struct let run ~root ~heads = let conf = conf root in - let* repo = Store.Repo.v conf in - let* heads = + let repo = Store.Repo.v conf in + let heads = match heads with | None -> Store.Repo.heads repo | Some heads -> - Lwt_list.filter_map_s + List.filter_map (fun x -> match Repr.of_string Store.Hash.t x with | Ok x -> Store.Commit.of_hash repo x - | Error (`Msg m) -> Fmt.kstr Lwt.fail_with "Invalid hash %S" m) + | Error (`Msg m) -> Fmt.kstr failwith "Invalid hash %S" m) heads in - let* () = - Store.integrity_check_inodes ~heads repo >|= function + let () = + match Store.integrity_check_inodes ~heads repo with | Ok `No_error -> [%logs.app "Ok"] | Error (`Cannot_fix msg) -> Fmt.failwith "Error: %s" msg in @@ -292,9 +289,7 @@ module Make (Store : Store) = struct let term_internal = Cmdliner.Term.( - const (fun root heads () -> Lwt_main.run (run ~root ~heads)) - $ path - $ heads) + const (fun root heads () -> run ~root ~heads) $ path $ heads) let term = let doc = "Check integrity of inodes in an existing store." in @@ -322,35 +317,34 @@ module Make (Store : Store) = struct let run ~root ~commit ~dump_blob_paths_to () = let conf = conf root in - let* repo = Store.Repo.v conf in - let* commit = + let repo = Store.Repo.v conf in + let commit = match commit with | None -> ( - let* heads = Store.Repo.heads repo in + let heads = Store.Repo.heads repo in match heads with - | [] -> Lwt.fail_with "No heads found" - | [ head ] -> Lwt.return head + | [] -> failwith "No heads found" + | [ head ] -> head | ls -> - Fmt.kstr Lwt.fail_with + Fmt.kstr failwith "Several heads found, please specify one. Heads = %a" Fmt.(list ~sep:comma Store.Commit.pp_hash) ls) | Some hash -> ( match Repr.of_string Store.Hash.t hash with | Ok x -> ( - Store.Commit.of_hash repo x >>= function - | None -> - Fmt.kstr Lwt.fail_with "Commit with hash %s not found" hash - | Some x -> Lwt.return x) - | Error (`Msg m) -> Fmt.kstr Lwt.fail_with "Invalid hash %S" m) + match Store.Commit.of_hash repo x with + | None -> Fmt.kstr failwith "Commit with hash %s not found" hash + | Some x -> x) + | Error (`Msg m) -> Fmt.kstr failwith "Invalid hash %S" m) in - let* () = Store.stats ~dump_blob_paths_to ~commit repo in + let () = Store.stats ~dump_blob_paths_to ~commit repo in Store.Repo.close repo let term_internal = Cmdliner.Term.( const (fun root commit dump_blob_paths_to () -> - Lwt_main.run (run ~root ~commit ~dump_blob_paths_to ())) + run ~root ~commit ~dump_blob_paths_to ()) $ path $ commit $ dump_blob_paths_to) diff --git a/src/irmin-pack/unix/checks_intf.ml b/src/irmin-pack/unix/checks_intf.ml index 9c9f93829b..828b65d341 100644 --- a/src/irmin-pack/unix/checks_intf.ml +++ b/src/irmin-pack/unix/checks_intf.ml @@ -33,7 +33,7 @@ end module type S = sig (** Reads basic metrics from an existing store and prints them to stdout. *) module Stat : sig - include Subcommand with type run := root:string -> unit Lwt.t + include Subcommand with type run := root:string -> unit (** Internal implementation utilities exposed for use in other integrity checks. *) @@ -67,7 +67,7 @@ module type S = sig always:bool -> heads:string list option -> unit -> - unit Lwt.t + unit val handle_result : ?ppf:Format.formatter -> @@ -90,7 +90,7 @@ module type S = sig module Integrity_check_inodes : sig include Subcommand - with type run := root:string -> heads:string list option -> unit Lwt.t + with type run := root:string -> heads:string list option -> unit end (** Traverses a commit to get stats on its underlying tree. *) @@ -102,7 +102,7 @@ module type S = sig commit:string option -> dump_blob_paths_to:string option -> unit -> - unit Lwt.t + unit end val cli : @@ -162,15 +162,15 @@ module type Sigs = sig * [< `Contents of XKey.t | `Inode of XKey.t | `Node of XKey.t ]) list) -> iter: - (contents:(XKey.hash Pack_key.t -> unit Lwt.t) -> - node:(XKey.t -> unit Lwt.t) -> + (contents:(XKey.hash Pack_key.t -> unit) -> + node:(XKey.t -> unit) -> pred_node: (X.Repo.t -> XKey.t -> - [> `Contents of XKey.t | `Node of XKey.t ] list Lwt.t) -> - pred_commit:(X.Repo.t -> XKey.t -> [> `Node of XKey.t ] list Lwt.t) -> + [> `Contents of XKey.t | `Node of XKey.t ] list) -> + pred_commit:(X.Repo.t -> XKey.t -> [> `Node of XKey.t ] list) -> X.Repo.t -> - unit Lwt.t) -> + unit) -> check: (offset:int63 -> length:int -> @@ -178,7 +178,7 @@ module type Sigs = sig (unit, [< `Absent_value | `Wrong_hash ]) result) -> recompute_hash:(X.Node.value -> XKey.hash) -> X.Repo.t -> - ([> `No_error ], [> `Cannot_fix of string ]) result Lwt.t + ([> `No_error ], [> `Cannot_fix of string ]) result val check_inodes : ?ppf:Format.formatter -> @@ -186,15 +186,15 @@ module type Sigs = sig (pred_node: (X.Repo.t -> XKey.t -> - ([> `Contents of XKey.t | `Node of XKey.t ] as 'a) list Lwt.t) -> - node:(XKey.t -> unit Lwt.t) -> - commit:(XKey.t -> unit Lwt.t) -> + ([> `Contents of XKey.t | `Node of XKey.t ] as 'a) list) -> + node:(XKey.t -> unit) -> + commit:(XKey.t -> unit) -> X.Repo.t -> - unit Lwt.t) -> - pred:(X.Repo.t -> XKey.t -> 'a list Lwt.t) -> - check:(XKey.t -> (unit, string) result Lwt.t) -> + unit) -> + pred:(X.Repo.t -> XKey.t -> 'a list) -> + check:(XKey.t -> (unit, string) result) -> X.Repo.t -> - ([> `No_error ], [> `Cannot_fix of string ]) result Lwt.t + ([> `No_error ], [> `Cannot_fix of string ]) result end module Stats (S : sig diff --git a/src/irmin-pack/unix/dune b/src/irmin-pack/unix/dune index aaf19e4f82..ebca669167 100644 --- a/src/irmin-pack/unix/dune +++ b/src/irmin-pack/unix/dune @@ -8,8 +8,7 @@ irmin irmin-pack logs - lwt - lwt.unix + eio mtime cmdliner optint diff --git a/src/irmin-pack/unix/gc.ml b/src/irmin-pack/unix/gc.ml index c61ba8c2b5..2a7008b477 100644 --- a/src/irmin-pack/unix/gc.ml +++ b/src/irmin-pack/unix/gc.ml @@ -30,8 +30,8 @@ module Make (Args : Gc_args.S) = struct task : Async.t; unlink : bool; new_suffix_start_offset : int63; - resolver : (Stats.Latest_gc.stats, Errs.t) result Lwt.u; - promise : (Stats.Latest_gc.stats, Errs.t) result Lwt.t; + resolver : (Stats.Latest_gc.stats, Errs.t) result Eio.Promise.u; + promise : (Stats.Latest_gc.stats, Errs.t) result Eio.Promise.t; dispatcher : Dispatcher.t; fm : Fm.t; contents : read Contents_store.t; @@ -109,7 +109,7 @@ module Make (Args : Gc_args.S) = struct after a failed gc. *) unlink_result_file (); (* internal promise for gc *) - let promise, resolver = Lwt.wait () in + let promise, resolver = Eio.Promise.create () in (* start worker task *) let task = Async.async (fun () -> @@ -246,7 +246,7 @@ module Make (Args : Gc_args.S) = struct let finalise ~wait t = match t.resulting_stats with - | Some partial_stats -> Lwt.return_ok (`Finalised partial_stats) + | Some partial_stats -> Ok (`Finalised partial_stats) | None -> ( let partial_stats = t.partial_stats in let partial_stats = @@ -262,7 +262,7 @@ module Make (Args : Gc_args.S) = struct in let result = - let open Result_syntax in + let (let*) = Result.bind in match (status, gc_output) with | `Success, Ok gc_results -> let partial_stats = @@ -289,30 +289,29 @@ module Make (Args : Gc_args.S) = struct "Gc ended successfully. %a" (Irmin.Type.pp Stats.Latest_gc.stats_t) stats]; - let () = Lwt.wakeup_later t.resolver (Ok stats) in + let () = Eio.Promise.resolve_ok t.resolver stats in Ok (`Finalised stats) | _ -> clean_after_abort t; let err = gc_errors status gc_output in - let () = Lwt.wakeup_later t.resolver err in + let () = Eio.Promise.resolve t.resolver err in err in - Lwt.return result + result in if wait then - let* status = Async.await t.task in + let status = Async.await t.task in go status else match Async.status t.task with - | `Running -> Lwt.return_ok `Running + | `Running -> Ok `Running | #Async.outcome as status -> go status) let finalise_without_swap t = - let* status = Async.await t.task in + let status = Async.await t.task in let gc_output = read_gc_output ~root:t.root ~generation:t.generation in match (status, gc_output) with | `Success, Ok gc_results -> - Lwt.return { Control_file_intf.Payload.Upper.Latest.generation = Fm.generation t.fm + 1; @@ -322,8 +321,7 @@ module Make (Args : Gc_args.S) = struct mapping_end_poff = Some gc_results.mapping_size; } | _ -> - let r = gc_errors status gc_output |> Errs.raise_if_error in - Lwt.return r + gc_errors status gc_output |> Errs.raise_if_error let on_finalise t f = (* Ignore returned promise since the purpose of this @@ -332,7 +330,7 @@ module Make (Args : Gc_args.S) = struct implementation detail. This is safe since the callback [f] is attached to [t.running_gc.promise], which is referenced for the lifetime of a GC process. *) - let _ = Lwt.bind t.promise f in + let _ = f (Eio.Promise.await t.promise) in () let cancel t = diff --git a/src/irmin-pack/unix/gc.mli b/src/irmin-pack/unix/gc.mli index 1660ba9e0f..0537656daf 100644 --- a/src/irmin-pack/unix/gc.mli +++ b/src/irmin-pack/unix/gc.mli @@ -43,20 +43,19 @@ module Make wait:bool -> t -> ([> `Running | `Finalised of Stats.Latest_gc.stats ], Args.Errs.t) result - Lwt.t (** [finalise ~wait t] returns the state of the GC process. If [wait = true], the call will block until GC finishes. *) val on_finalise : - t -> ((Stats.Latest_gc.stats, Args.Errs.t) result -> unit Lwt.t) -> unit + t -> ((Stats.Latest_gc.stats, Args.Errs.t) result -> unit) -> unit (** Attaches a callback to the GC process, which will be called when the GC finalises. *) val cancel : t -> bool val finalise_without_swap : - t -> Control_file_intf.Payload.Upper.Latest.gced Lwt.t + t -> Control_file_intf.Payload.Upper.Latest.gced (** Waits for the current gc to finish and returns immediately without swapping the files and doing the other finalisation steps from [finalise]. Returns the [gced] status to create a fresh control file for the snapshot. *) diff --git a/src/irmin-pack/unix/gc_args.ml b/src/irmin-pack/unix/gc_args.ml index 3441c51319..197d3bea4d 100644 --- a/src/irmin-pack/unix/gc_args.ml +++ b/src/irmin-pack/unix/gc_args.ml @@ -80,4 +80,4 @@ module type S = sig and type dict = Fm.Dict.t and type dispatcher = Dispatcher.t and type hash = hash -end +end \ No newline at end of file diff --git a/src/irmin-pack/unix/inode_intf.ml b/src/irmin-pack/unix/inode_intf.ml index d73ed90435..0a5429b200 100644 --- a/src/irmin-pack/unix/inode_intf.ml +++ b/src/irmin-pack/unix/inode_intf.ml @@ -35,7 +35,7 @@ module type Persistent = sig include Irmin_pack.Checkable with type 'a t := 'a t and type hash := hash (* val reload : 'a t -> unit *) - val integrity_check_inodes : [ `Read ] t -> key -> (unit, string) result Lwt.t + val integrity_check_inodes : [ `Read ] t -> key -> (unit, string) result module Pack : Pack_store.S diff --git a/src/irmin-pack/unix/pack_store.ml b/src/irmin-pack/unix/pack_store.ml index 449f1a3de6..b6cef955fa 100644 --- a/src/irmin-pack/unix/pack_store.ml +++ b/src/irmin-pack/unix/pack_store.ml @@ -117,7 +117,7 @@ struct let index_direct t hash = index_direct_with_kind t hash |> Option.map (fun (key, _) -> key) - let index t hash = Lwt.return (index_direct t hash) + let index t hash = index_direct t hash let v ~config ~fm ~dict ~dispatcher ~lru = let indexing_strategy = Conf.indexing_strategy config in @@ -251,9 +251,7 @@ struct || Lru.mem t.lru offset || pack_file_contains_key t k - let mem t k = - let b = unsafe_mem t k in - Lwt.return b + let mem t k = unsafe_mem t k let check_hash h v = let h' = Val.hash v in @@ -396,9 +394,7 @@ struct let key_of_offset ?volume_identifier:_ _ = Pack_key.v_offset in find_in_pack_file ~key_of_offset t key - let find t k = - let v = unsafe_find ~check_integrity:true t k in - Lwt.return v + let find t k = unsafe_find ~check_integrity:true t k let integrity_check ~offset ~length hash t = let k = Pack_key.v_direct ~offset ~length hash in @@ -425,7 +421,7 @@ struct repo.batch instead."]; let on_success res = Fm.flush t.fm |> Errs.raise_if_error; - Lwt.return res + res in let on_fail exn = [%log.info @@ -440,7 +436,9 @@ struct in raise exn in - Lwt.try_bind (fun () -> f (cast t)) on_success on_fail + match f (cast t) with + | v -> on_success v + | exception exn -> on_fail exn let unsafe_append ~ensure_unique ~overcommit t hash v = let kind = Val.kind v in @@ -493,7 +491,7 @@ struct if unsafe_mem t key then key else unguarded_append () let unsafe_add t hash v = - unsafe_append ~ensure_unique:true ~overcommit:false t hash v |> Lwt.return + unsafe_append ~ensure_unique:true ~overcommit:false t hash v let add t v = unsafe_add t (Val.hash v) v @@ -503,7 +501,7 @@ struct The caller should close the file manager. We could clear the caches here but that really is not necessary. *) - let close _ = Lwt.return () + let close _ = () let purge_lru t = Lru.clear t.lru end diff --git a/src/irmin-pack/unix/snapshot.ml b/src/irmin-pack/unix/snapshot.ml index 1ed1fae40f..b9c8413f42 100644 --- a/src/irmin-pack/unix/snapshot.ml +++ b/src/irmin-pack/unix/snapshot.ml @@ -127,7 +127,7 @@ module Make (Args : Args) = struct before the call to [aux]. *) assert false | Direct { length; offset; hash; _ } -> - if v.visited hash then Lwt.return_unit + if v.visited hash then () else ( set_visit hash; [%log.debug "visit hash: %a, %a" pp_hash hash pp_kind kind]; @@ -152,7 +152,7 @@ module Make (Args : Args) = struct let children = decode_children_offsets ~off:offset ~len:length t in - let* () = Lwt_list.iter_s (fun key -> aux key) children in + let () = List.iter (fun key -> aux key) children in let value = Inode_pack.unsafe_find ~check_integrity:false t.inode_pack key @@ -179,8 +179,8 @@ module Make (Args : Args) = struct | Indexed hash -> key_of_hash hash t.inode_pack |> fst | Direct _ -> root_key in - let* () = aux (root_key, root_kind) in - Lwt.return !total_visited + let () = aux (root_key, root_kind) in + !total_visited let run_in_memory t f_contents f_inodes root_key = [%log.info "iter in memory"]; @@ -205,10 +205,10 @@ module Make (Args : Args) = struct Fmt.failwith "Should not visit hash twice. Hash: %a " pp_hash h else Index.replace index h () in - let* total = iter t { visited; set_visit } f_contents f_inodes root_key in + let total = iter t { visited; set_visit } f_contents f_inodes root_key in Index.close index; rm_index path; - Lwt.return total + total let run ?on_disk = match on_disk with @@ -255,21 +255,21 @@ module Make (Args : Args) = struct index : (path * Index.t) option; } - let save_contents t b : Hash.t Pack_key.t Lwt.t = - let* key = + let save_contents t b : Hash.t Pack_key.t = + let key = Contents_pack.batch t.contents_pack (fun writer -> Contents_pack.add writer b) in let hash = Inode.Key.to_hash key in t.set_visit hash key; - Lwt.return key + key - let save_inodes t i : Hash.t Pack_key.t Lwt.t = + let save_inodes t i : Hash.t Pack_key.t = let inode = Inode.of_snapshot t.inode_pack ~index:t.visited i in let key = Inode.save ~allow_non_root:true t.inode_pack inode in let hash = Inode.Key.to_hash key in t.set_visit hash key; - Lwt.return key + key let hash_not_found h = Fmt.failwith diff --git a/src/irmin-pack/unix/snapshot_intf.ml b/src/irmin-pack/unix/snapshot_intf.ml index 16ce2a917f..d3e2bd828a 100644 --- a/src/irmin-pack/unix/snapshot_intf.ml +++ b/src/irmin-pack/unix/snapshot_intf.ml @@ -47,10 +47,10 @@ module type Sigs = sig val run : ?on_disk:[ `Path of string ] -> t -> - (Contents_pack.value -> unit Lwt.t) -> - (Inode.Snapshot.inode -> unit Lwt.t) -> + (Contents_pack.value -> unit) -> + (Inode.Snapshot.inode -> unit) -> Hash.t Pack_key.t * Pack_value.Kind.t -> - int Lwt.t + int val close : t -> @@ -73,8 +73,8 @@ module type Sigs = sig read Inode.Pack.t -> t - val save_contents : t -> Contents_pack.value -> Hash.t Pack_key.t Lwt.t - val save_inodes : t -> Inode.Snapshot.inode -> Hash.t Pack_key.t Lwt.t + val save_contents : t -> Contents_pack.value -> Hash.t Pack_key.t + val save_inodes : t -> Inode.Snapshot.inode -> Hash.t Pack_key.t val close : t -> unit end end diff --git a/src/irmin-pack/unix/store.ml b/src/irmin-pack/unix/store.ml index 36e65354da..2cdb193e03 100644 --- a/src/irmin-pack/unix/store.ml +++ b/src/irmin-pack/unix/store.ml @@ -17,6 +17,8 @@ open! Import include Store_intf +let ( let* ) = Result.bind + module Maker (Config : Conf.S) = struct type endpoint = unit @@ -118,7 +120,7 @@ module Maker (Config : Conf.S) = struct include Atomic_write.Closeable (AW) let v ?fresh ?readonly path = - AW.v ?fresh ?readonly path >|= make_closeable + AW.v ?fresh ?readonly path |> make_closeable end module Slice = Irmin.Backend.Slice.Make (Contents) (Node) (Commit) @@ -189,7 +191,7 @@ module Maker (Config : Conf.S) = struct let contents = Contents.CA.v ~config ~fm ~dict ~dispatcher ~lru in let node = Node.CA.v ~config ~fm ~dict ~dispatcher ~lru in let commit = Commit.CA.v ~config ~fm ~dict ~dispatcher ~lru in - let+ branch = + let branch = let root = Conf.root config in let fresh = Conf.fresh config in let readonly = Conf.readonly config in @@ -269,29 +271,26 @@ module Maker (Config : Conf.S) = struct match t.running_gc with | Some _ -> [%log.info "Repo is alreadying running GC. Skipping."]; - Lwt.return false + false | None -> ( let result = start ~unlink ~use_auto_finalisation ~output t commit_key in - match result with - | Ok _ -> Lwt.return true - | Error e -> Errs.raise_error e) + match result with Ok _ -> true | Error e -> Errs.raise_error e) let finalise_exn ?(wait = false) t = - let* result = + let result = match t.running_gc with - | None -> Lwt.return_ok `Idle + | None -> Ok `Idle | Some { gc; _ } -> - if t.during_batch then - Lwt.return_error `Gc_forbidden_during_batch + if t.during_batch then Error `Gc_forbidden_during_batch else Gc.finalise ~wait gc in match result with | Ok (`Finalised _ as x) -> t.running_gc <- None; - Lwt.return x - | Ok waited -> Lwt.return waited + x + | Ok waited -> waited | Error e -> t.running_gc <- None; Errs.raise_error e @@ -305,11 +304,10 @@ module Maker (Config : Conf.S) = struct let try_auto_finalise_exn t = match t.running_gc with - | None | Some { use_auto_finalisation = false; _ } -> - Lwt.return_unit + | None | Some { use_auto_finalisation = false; _ } -> () | Some { use_auto_finalisation = true; _ } -> - let* _ = finalise_exn ~wait:false t in - Lwt.return_unit + let _ = finalise_exn ~wait:false t in + () let latest_gc_target t = let pl = File_manager.(Control.payload (control t.fm)) in @@ -350,14 +348,14 @@ module Maker (Config : Conf.S) = struct in (* The GC action here does not matter, since we'll not fully finalise it *) - let* launched = + let launched = start_exn ~use_auto_finalisation:false ~output:(`External path) t commit_key in let () = if not launched then Errs.raise_error `Forbidden_during_gc in - let* gced = + let gced = match t.running_gc with | None -> assert false | Some { gc; _ } -> Gc.finalise_without_swap gc @@ -368,11 +366,10 @@ module Maker (Config : Conf.S) = struct |> Errs.raise_if_error in let branch_path = Irmin_pack.Layout.V4.branch ~root:path in - let* branch_store = + let branch_store = Branch.v ~fresh:true ~readonly:false branch_path in - let* () = Branch.close branch_store in - Lwt.return_unit + Branch.close branch_store end let is_split_allowed = Gc.is_allowed @@ -408,7 +405,7 @@ module Maker (Config : Conf.S) = struct else let c0 = Mtime_clock.counter () in let try_finalise () = Gc.try_auto_finalise_exn t in - let* _ = try_finalise () in + let _ = try_finalise () in t.during_batch <- true; let contents = Contents.CA.cast t.contents in let node = Node.CA.Pack.cast t.node in @@ -421,8 +418,8 @@ module Maker (Config : Conf.S) = struct [%log.info "[pack] batch completed in %.6fs" s]; t.during_batch <- false; File_manager.flush t.fm |> Errs.raise_if_error; - let* _ = try_finalise () in - Lwt.return res + let _ = try_finalise () in + res in let on_fail exn = t.during_batch <- false; @@ -441,17 +438,20 @@ module Maker (Config : Conf.S) = struct (* Kill gc process in at_exit. *) raise exn in - Lwt.try_bind (fun () -> f contents node commit) on_success on_fail + match f contents node commit with + | v -> on_success v + | exception exn -> on_fail exn let close t = (* Step 1 - Kill the gc process if it is running *) let _ = Gc.cancel t in (* Step 2 - Close the files *) let () = File_manager.close t.fm |> Errs.raise_if_error in - Branch.close t.branch >>= fun () -> + Branch.close t.branch; (* Step 3 - Close the in-memory abstractions *) - Contents.CA.close (contents_t t) >>= fun () -> - Node.CA.close (snd (node_t t)) >>= fun () -> + (* Dict.close t.dict; *) + Contents.CA.close (contents_t t); + Node.CA.close (snd (node_t t)); Commit.CA.close (snd (commit_t t)) end end @@ -487,9 +487,7 @@ module Maker (Config : Conf.S) = struct Integrity_checks.check_always ?ppf ~auto_repair ~check index let integrity_check_minimal ?ppf ?heads t = - let* heads = - match heads with None -> Repo.heads t | Some m -> Lwt.return m - in + let heads = match heads with None -> Repo.heads t | Some m -> m in let hashes = List.map (fun x -> `Commit (Commit.key x)) heads in let iter ~contents ~node ~pred_node ~pred_commit repo = Repo.iter ~cache_size:1_000_000 ~min:[] ~max:hashes ~contents ~node @@ -528,7 +526,7 @@ module Maker (Config : Conf.S) = struct end) in let t = Stats.v () in let pred_node repo k = - X.Node.find (X.Repo.node_t repo) k >|= function + match X.Node.find (X.Repo.node_t repo) k with | None -> Fmt.failwith "key %a not found" pp_key k | Some v -> let width = X.Node.Val.length v in @@ -553,7 +551,7 @@ module Maker (Config : Conf.S) = struct in (* We are traversing only one commit. *) let pred_commit repo k = - X.Commit.find (X.Repo.commit_t repo) k >|= function + match X.Commit.find (X.Repo.commit_t repo) k with | None -> [] | Some c -> let node = X.Commit.Val.node c in @@ -562,16 +560,15 @@ module Maker (Config : Conf.S) = struct in let pred_contents _repo k = Stats.visit_contents t (XKey.to_hash k); - Lwt.return [] + [] in (* We want to discover all paths to a node, so we don't cache nodes during traversal. *) - let* () = + let () = Repo.breadth_first_traversal ~cache_size:0 ~pred_node ~pred_commit ~pred_contents ~max:[ commit ] repo in - Stats.pp_results ~dump_blob_paths_to t; - Lwt.return_unit + Stats.pp_results ~dump_blob_paths_to t let run ~dump_blob_paths_to ~commit repo = Printexc.record_backtrace true; @@ -607,7 +604,7 @@ module Maker (Config : Conf.S) = struct | exn -> raise exn in let error_msg = Fmt.str "[%s] resulted in error: %s" context err in - Lwt.return_error (`Msg error_msg) + Error (`Msg error_msg) let map_errors context (error : Errs.t) = let err_msg = @@ -623,11 +620,11 @@ module Maker (Config : Conf.S) = struct let start repo commit_key = try - let* started = + let started = X.Repo.Gc.start_exn ~unlink:true ~use_auto_finalisation:true repo commit_key in - Lwt.return_ok started + Ok started with exn -> catch_errors "Start GC" exn let is_finished = X.Repo.Gc.is_finished @@ -635,16 +632,16 @@ module Maker (Config : Conf.S) = struct let wait repo = try - let* result = finalise_exn ~wait:true repo in + let result = finalise_exn ~wait:true repo in match result with | `Running -> assert false (* [~wait:true] should never return [Running] *) - | `Idle -> Lwt.return_ok None - | `Finalised stats -> Lwt.return_ok @@ Some stats + | `Idle -> Ok None + | `Finalised stats -> Ok (Some stats) with exn -> catch_errors "Wait for GC" exn - let run ?(finished = fun _ -> Lwt.return_unit) repo commit_key = - let* started = start repo commit_key in + let run ?(finished = fun _ -> ()) repo commit_key = + let started = start repo commit_key in match started with | Ok r -> if r then @@ -654,8 +651,8 @@ module Maker (Config : Conf.S) = struct | Error err -> let err_msg = map_errors "Finalise GC" err in finished @@ Error err_msg); - Lwt.return_ok r - | Error _ as e -> Lwt.return e + Ok r + | Error _ as e -> e let is_allowed = X.Repo.Gc.is_allowed let cancel repo = X.Repo.Gc.cancel repo @@ -703,12 +700,12 @@ module Maker (Config : Conf.S) = struct match root_key with | `Contents _ -> Fmt.failwith "[root_key] cannot be of type contents" | `Node key -> - let* total = + let total = Export.run ?on_disk export f_contents f_nodes (key, Pack_value.Kind.Inode_v2_root) in Export.close export |> Errs.raise_if_error; - Lwt.return total + total end let export = Export.iter diff --git a/src/irmin-pack/unix/store_intf.ml b/src/irmin-pack/unix/store_intf.ml index 1111dc25e7..70ca9230fc 100644 --- a/src/irmin-pack/unix/store_intf.ml +++ b/src/irmin-pack/unix/store_intf.ml @@ -35,7 +35,6 @@ module type S = sig ( [> `Fixed of int | `No_error ], [> `Cannot_fix of string | `Corrupted of int ] ) result - Lwt.t (** Checks the integrity of the repository. if [auto_repair] is [true], will also try to fix the issues. [ppf] is a formatter for progressive reporting. [`Fixed] and [`Corrupted] report the number of fixed/corrupted @@ -44,7 +43,7 @@ module type S = sig val integrity_check_inodes : ?heads:commit list -> repo -> - ([> `No_error ], [> `Cannot_fix of string ]) result Lwt.t + ([> `No_error ], [> `Cannot_fix of string ]) result val traverse_pack_file : [ `Reconstruct_index of [ `In_place | `Output of string ] @@ -102,7 +101,7 @@ module type S = sig (** [flush t] flush read-write pack on disk. Raises [RO_Not_Allowed] if called by a readonly instance.*) - val create_one_commit_store : repo -> commit_key -> string -> unit Lwt.t + val create_one_commit_store : repo -> commit_key -> string -> unit (** [create_one_commit_store t key path] creates a new store at [path] from the existing one, containing only one commit, specified by the [key]. Note that this operation is blocking. @@ -120,7 +119,7 @@ module type S = sig (** {1 Low-level API} *) - val start_exn : ?unlink:bool -> repo -> commit_key -> bool Lwt.t + val start_exn : ?unlink:bool -> repo -> commit_key -> bool (** [start_exn] tries to start the GC process and returns true if the GC is launched. If a GC is already running, a new one is not started. @@ -133,7 +132,7 @@ module type S = sig TODO: Detail exceptions raised. *) - val finalise_exn : ?wait:bool -> repo -> process_state Lwt.t + val finalise_exn : ?wait:bool -> repo -> process_state (** [finalise_exn ?wait repo] waits for the GC process to finish in order to finalise it. It returns the state of the GC process from the point of view of the function call; subsequent calls of [finalise_exn] after a @@ -158,10 +157,10 @@ module type S = sig logging *) val run : - ?finished:((Stats.Latest_gc.stats, msg) result -> unit Lwt.t) -> + ?finished:((Stats.Latest_gc.stats, msg) result -> unit) -> repo -> commit_key -> - (bool, msg) result Lwt.t + (bool, msg) result (** [run repo commit_key] attempts to start a GC process for a [repo] by discarding or archiving all data prior to [commit_key] (depending on {!behaviour}. If a GC process is already running, a new one will not be @@ -181,7 +180,7 @@ module type S = sig returned as pretty-print error messages; others are re-raised. The error messages should be used only for informational purposes, like logging. *) - val wait : repo -> (Stats.Latest_gc.stats option, msg) result Lwt.t + val wait : repo -> (Stats.Latest_gc.stats option, msg) result (** [wait repo] blocks until GC is finished or is idle. If a GC finalises, its stats are returned. @@ -240,9 +239,9 @@ module type S = sig val export : ?on_disk:[ `Path of string ] -> repo -> - (t -> unit Lwt.t) -> + (t -> unit) -> root_key:Tree.kinded_key -> - int Lwt.t + int (** [export ?on_disk repo f ~root_key] applies [f] to all inodes and contents in a rooted tree, with root specified by [root_key]. @@ -276,7 +275,7 @@ module type S = sig - if [on_disk] is [`Path path], a temporary index is created at path. - if [on_disk] is [`Reuse] the store's index is reused. *) - val save_elt : process -> t -> node_key Lwt.t + val save_elt : process -> t -> node_key (** [save_elt snapshot elt] saves [elt] to the store. *) val close : process -> repo -> unit @@ -287,7 +286,7 @@ module type S = sig (** {1 Statistics} *) val stats : - dump_blob_paths_to:string option -> commit:commit -> repo -> unit Lwt.t + dump_blob_paths_to:string option -> commit:commit -> repo -> unit (** {1 Internals} *) diff --git a/src/irmin-test/store.ml b/src/irmin-test/store.ml index f57bb8176b..711001b852 100644 --- a/src/irmin-test/store.ml +++ b/src/irmin-test/store.ml @@ -989,12 +989,12 @@ module Make (S : Generic_key) = struct 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 = + 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 = + let c_none = S.test_set_and_get_exn t ~info:(infof "init") [ "a"; "b" ] ~test:(Some v1) ~set:(Some v1) in @@ -1002,22 +1002,22 @@ module Make (S : Generic_key) = struct let message0 = "first" in let message1 = "second" in let v3 = "v3" in - let* c0 = + 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 = + 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 + 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 + 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 diff --git a/src/irmin/watch_intf.ml b/src/irmin/watch_intf.ml index 5ac0d75fd5..12cb151599 100644 --- a/src/irmin/watch_intf.ml +++ b/src/irmin/watch_intf.ml @@ -82,7 +82,7 @@ module type Sigs = sig (** [none] is the hooks which asserts false. *) val set_watch_switch : Eio.Switch.t -> unit - (** A terrible hack that will need fixed... *) + (** A terrible hack that will need fixed... *) val set_listen_dir_hook : hook -> unit (** Register a function which looks for file changes in a directory and return diff --git a/test/irmin-pack/common.ml b/test/irmin-pack/common.ml index bcf4cd3029..534cee5628 100644 --- a/test/irmin-pack/common.ml +++ b/test/irmin-pack/common.ml @@ -166,7 +166,7 @@ struct let lru = Irmin_pack_unix.Lru.create config in let pack = Pack.v ~config ~fm ~dict ~dispatcher ~lru in (f := fun () -> File_manager.flush fm |> Errs.raise_if_error); - { name; index; pack; dict; fm } |> Lwt.return + { name; index; pack; dict; fm } let get_rw_pack () = let name = fresh_name "" in @@ -177,9 +177,8 @@ struct let close_pack t = Index.close_exn t.index; - File_manager.close t.fm |> Errs.raise_if_error; + File_manager.close t.fm |> Errs.raise_if_error (* closes pack and dict *) - Lwt.return_unit end module Alcotest = struct @@ -207,19 +206,18 @@ module Alcotest = struct msg (Printexc.to_string exn)) (** TODO: upstream this to Alcotest *) - let check_raises_lwt msg exn (type a) (f : unit -> a Lwt.t) = - Lwt.try_bind f - (fun _ -> + let check_raises msg exn (type a) (f : unit -> a) = + try + let (_ : a) = f () in + Alcotest.failf + "Fail %s: expected function to raise %s, but it returned instead." msg + (Printexc.to_string exn) + with + | e when e = exn -> () + | e -> 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)) + "Fail %s: expected function to raise %s, but it raised %s instead." + msg (Printexc.to_string exn) (Printexc.to_string e) let testable_repr t = Alcotest.testable (Irmin.Type.pp t) Irmin.Type.(unstage (equal t)) diff --git a/test/irmin-pack/common.mli b/test/irmin-pack/common.mli index d5f9530456..521d1e29fe 100644 --- a/test/irmin-pack/common.mli +++ b/test/irmin-pack/common.mli @@ -57,10 +57,10 @@ module Alcotest : sig val check_raises_pack_error : string -> (Irmin_pack_unix.Errors.base_error -> bool) -> - (unit -> _ Lwt.t) -> - unit Lwt.t + (unit -> _) -> + unit - val check_raises_lwt : string -> exn -> (unit -> _ Lwt.t) -> unit Lwt.t + val check_raises : string -> exn -> (unit -> _) -> unit val check_repr : ?pos:Source_code_position.pos -> @@ -110,10 +110,10 @@ end) : sig dict : Dict.t; } - val get_rw_pack : unit -> t Lwt.t - val get_ro_pack : string -> t Lwt.t - val reopen_rw : string -> t Lwt.t - val close_pack : t -> unit Lwt.t + val get_rw_pack : unit -> t + val get_ro_pack : string -> t + val reopen_rw : string -> t + val close_pack : t -> unit end val get : 'a option -> 'a diff --git a/test/irmin-pack/dune b/test/irmin-pack/dune index 235ac45a82..dcbcd82bff 100644 --- a/test/irmin-pack/dune +++ b/test/irmin-pack/dune @@ -32,8 +32,6 @@ irmin-pack.mem irmin-tezos logs - lwt - lwt.unix fpath hex) (preprocess @@ -42,7 +40,7 @@ (executable (name test) (modules test) - (libraries irmin irmin-test test_pack)) + (libraries eio_main irmin irmin-test test_pack)) (rule (alias runtest) diff --git a/test/irmin-pack/test.ml b/test/irmin-pack/test.ml index 8b35dbfa8f..dc08b5092b 100644 --- a/test/irmin-pack/test.ml +++ b/test/irmin-pack/test.ml @@ -15,7 +15,7 @@ *) let () = - Lwt_main.run - @@ Irmin_test.Store.run "irmin-pack" ~misc:Test_pack.misc - ~sleep:Lwt_unix.sleep + Eio_main.run @@ fun _env -> + Irmin_test.Store.run "irmin-pack" ~misc:Test_pack.misc + ~sleep:Eio_unix.sleep (List.map (fun s -> (`Quick, s)) Test_pack.suite) diff --git a/test/irmin-pack/test_corrupted.ml b/test/irmin-pack/test_corrupted.ml index 43a54e00d1..faeb932016 100644 --- a/test/irmin-pack/test_corrupted.ml +++ b/test/irmin-pack/test_corrupted.ml @@ -50,11 +50,11 @@ let write_file path contents = let test_corrupted_control_file () = rm_dir root; let control_file_path = Filename.concat root "store.control" in - let* repo = Store.Repo.v (config ~fresh:true root) in + let repo = Store.Repo.v (config ~fresh:true root) in let control_file_blob0 = read_file control_file_path in - let* store = Store.main repo in - let* () = Store.set_exn ~info store [ "a" ] "b" in - let* () = Store.Repo.close repo in + let store = Store.main repo in + let () = Store.set_exn ~info store [ "a" ] "b" in + let () = Store.Repo.close repo in let control_file_blob1 = read_file control_file_path in assert (not (String.equal control_file_blob0 control_file_blob1)); assert (String.length control_file_blob0 = String.length control_file_blob1); @@ -68,22 +68,17 @@ let test_corrupted_control_file () = assert (not (String.equal control_file_blob0 control_file_mix)); assert (not (String.equal control_file_blob1 control_file_mix)); write_file control_file_path control_file_mix; - let* error = - Lwt.catch - (fun () -> - let+ r = Store.Repo.v (config ~fresh:false root) in - Ok r) - (fun exn -> Lwt.return (Error exn)) + let error = + try Ok (Store.Repo.v (config ~fresh:false root)) + with exn -> Error exn in (match error with | Error (Irmin_pack_unix.Errors.Pack_error (`Corrupted_control_file s)) -> Alcotest.(check string) "path is corrupted" s "_build/test-corrupted/store.control" - | _ -> Alcotest.fail "unexpected error"); - Lwt.return_unit + | _ -> Alcotest.fail "unexpected error") let tests = [ - Alcotest_lwt.test_case "Corrupted control file" `Quick (fun _switch -> - test_corrupted_control_file); + Alcotest.test_case "Corrupted control file" `Quick test_corrupted_control_file; ] diff --git a/test/irmin-pack/test_corrupted.mli b/test/irmin-pack/test_corrupted.mli index fa903bf99c..0793cf46c1 100644 --- a/test/irmin-pack/test_corrupted.mli +++ b/test/irmin-pack/test_corrupted.mli @@ -14,4 +14,4 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -val tests : unit Alcotest_lwt.test_case list +val tests : unit Alcotest.test_case list diff --git a/test/irmin-pack/test_dispatcher.ml b/test/irmin-pack/test_dispatcher.ml index de572c535a..854a61c44e 100644 --- a/test/irmin-pack/test_dispatcher.ml +++ b/test/irmin-pack/test_dispatcher.ml @@ -27,16 +27,16 @@ module Log = (val Logs.src_log src : Logs.LOG) let setup_store () = rm_dir root; let config = S.config root in - let* t = S.init_with_config config in - let* _ = S.commit_1 t in - let* t, c2 = S.commit_2 t in - let* t = S.checkout_exn t c2 in - let* t, _c3 = S.commit_3 t in + let t = S.init_with_config config in + let _ = S.commit_1 t in + let t, c2 = S.commit_2 t in + let t = S.checkout_exn t c2 in + let t, _c3 = S.commit_3 t in [%log.debug "Gc c1, keep c2, c3"]; - let* () = S.start_gc t c2 in - let* () = S.finalise_gc t in - let* () = S.close t in - Lwt.return config + let () = S.start_gc t c2 in + let () = S.finalise_gc t in + let () = S.close t in + config type t = { off : Int63.t; len : int; hex : string } @@ -76,7 +76,7 @@ let check_hex msg buf expected = (Bytes.to_string buf |> Hex.of_string |> Hex.show) let test_read () = - let* config = setup_store () in + let config = setup_store () in let fm = File_manager.open_ro config |> Errs.raise_if_error in let dsp = Dispatcher.v fm |> Errs.raise_if_error in let _ = @@ -97,7 +97,6 @@ let test_read () = test_accessor "commit_2" commit_2; test_accessor "node_3" node_3; - File_manager.close fm |> Errs.raise_if_error; - Lwt.return_unit + File_manager.close fm |> Errs.raise_if_error -let tests = [ Alcotest_lwt.test_case "read" `Quick (fun _switch -> test_read) ] +let tests = [ Alcotest.test_case "read" `Quick test_read ] diff --git a/test/irmin-pack/test_dispatcher.mli b/test/irmin-pack/test_dispatcher.mli index 4acc26805b..2b40d2f891 100644 --- a/test/irmin-pack/test_dispatcher.mli +++ b/test/irmin-pack/test_dispatcher.mli @@ -14,4 +14,4 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -val tests : unit Alcotest_lwt.test_case list +val tests : unit Alcotest.test_case list diff --git a/test/irmin-pack/test_existing_stores.ml b/test/irmin-pack/test_existing_stores.ml index ae9b4a88fb..9e7784f251 100644 --- a/test/irmin-pack/test_existing_stores.ml +++ b/test/irmin-pack/test_existing_stores.ml @@ -41,34 +41,34 @@ let root_v1_archive, root_v1, tmp = module Test (S : Irmin.Generic_key.KV with type Schema.Contents.t = string) = struct let check_commit repo commit bindings = - commit |> S.Commit.key |> S.Commit.of_key repo >>= function + match commit |> S.Commit.key |> S.Commit.of_key repo with | None -> Alcotest.failf "Commit `%a' is dangling in repo" S.Commit.pp_hash commit | Some commit -> let tree = S.Commit.tree commit in bindings - |> Lwt_list.iter_s (fun (key, value) -> + |> List.iter (fun (key, value) -> S.Tree.find tree key - >|= Alcotest.(check (option string)) - (Fmt.str "Expected binding [%a ↦ %s]" - Fmt.(Dump.list string) - key value) - (Some value)) + |> Alcotest.(check (option string)) + (Fmt.str "Expected binding [%a ↦ %s]" + Fmt.(Dump.list string) + key value) + (Some value)) let check_repo repo structure = structure - |> Lwt_list.iter_s @@ fun (branch, bindings) -> - S.Branch.find repo branch >>= function + |> List.iter @@ fun (branch, bindings) -> + match S.Branch.find repo branch with | None -> Alcotest.failf "Couldn't find expected branch `%s'" branch | Some commit -> check_commit repo commit bindings let commit_of_string repo c = match Irmin.Type.of_string S.Hash.t c with | Ok x -> ( - let* commit = S.Commit.of_hash repo x in + let commit = S.Commit.of_hash repo x in match commit with | None -> Alcotest.fail "could not find commit in store" - | Some x -> Lwt.return x) + | Some x -> x) | _ -> Alcotest.fail "could not read hash" let bin_string_of_string c = @@ -126,8 +126,8 @@ module Test_reconstruct = struct setup_test_env (); let conf = config ~readonly:false ~fresh:false root_v1 in (* Open store in RW to migrate it to V3. *) - let* repo = S.Repo.v conf in - let* () = S.Repo.close repo in + let repo = S.Repo.v conf in + let () = S.Repo.close repo in (* Test on a V3 store. *) S.test_traverse_pack_file (`Reconstruct_index `In_place) conf; let index_old = @@ -153,13 +153,14 @@ module Test_reconstruct = struct Index.close_exn index_new; [%log.app "Checking old bindings are still reachable post index reconstruction)"]; - let* r = S.Repo.v conf in - check_repo r archive >>= fun () -> S.Repo.close r + let r = S.Repo.v conf in + check_repo r archive; + S.Repo.close r let test_gc_allowed () = setup_test_env (); let conf = config ~readonly:false ~fresh:false root_v1 in - let* repo = S.Repo.v conf in + let repo = S.Repo.v conf in let allowed = S.Gc.is_allowed repo in Alcotest.(check bool) "deleting gc not allowed on stores with V1 objects" allowed false; @@ -179,7 +180,7 @@ module Test_corrupted_stores = struct let test () = setup_env (); - let* rw = S.Repo.v (config ~fresh:false root) in + let rw = S.Repo.v (config ~fresh:false root) in [%log.app "integrity check on a store where 3 entries are missing from pack"]; let* result = S.integrity_check ~auto_repair:false rw in @@ -271,19 +272,19 @@ module Test_corrupted_inode = struct let test () = setup_test_env (); - let* rw = S.Repo.v (config ~fresh:false root) in + let rw = S.Repo.v (config ~fresh:false root) in [%log.app "integrity check of inodes on a store with one corrupted inode"]; let c2 = "8d89b97726d9fb650d088cb7e21b78d84d132c6e" in - let* c2 = commit_of_string rw c2 in - let* result = S.integrity_check_inodes ~heads:[ c2 ] rw in + let c2 = commit_of_string rw c2 in + let result = S.integrity_check_inodes ~heads:[ c2 ] rw in (match result with | Ok _ -> Alcotest.failf "Store is corrupted for second commit, the check should fail" | Error _ -> ()); let c1 = "1b1e259ca4e7bb8dc32c73ade93d8181c29cebe6" in - let* c1 = commit_of_string rw c1 in - let* result = S.integrity_check_inodes ~heads:[ c1 ] rw in + let c1 = commit_of_string rw c1 in + let result = S.integrity_check_inodes ~heads:[ c1 ] rw in (match result with | Error _ -> Alcotest.fail @@ -304,21 +305,21 @@ module Test_traverse_gced = struct include Test (S) let commit_and_gc conf = - let* repo = S.Repo.v conf in - let* commit = + let repo = S.Repo.v conf in + let commit = commit_of_string repo "22e159de13b427226e5901defd17f0c14e744205" in let tree = S.Commit.tree commit in - let* tree = S.Tree.add tree [ "abba"; "baba" ] "x" in - let* commit = S.Commit.v repo ~info:S.Info.empty ~parents:[] tree in + let tree = S.Tree.add tree [ "abba"; "baba" ] "x" in + let commit = S.Commit.v repo ~info:S.Info.empty ~parents:[] tree in let commit_key = S.Commit.key commit in - let* _launched = S.Gc.start_exn ~unlink:false repo commit_key in - let* result = S.Gc.finalise_exn ~wait:true repo in - let* () = + let _launched = S.Gc.start_exn ~unlink:false repo commit_key in + let result = S.Gc.finalise_exn ~wait:true repo in + let () = match result with | `Running -> Alcotest.fail "expected finalised gc" (* consider `Idle as success because gc can finalise during commit as well *) - | `Idle | `Finalised _ -> Lwt.return_unit + | `Idle | `Finalised _ -> () in S.Repo.close repo @@ -329,23 +330,22 @@ module Test_traverse_gced = struct config ~readonly:false ~fresh:false ~indexing_strategy:Irmin_pack.Indexing_strategy.minimal root_local_build in - let* () = commit_and_gc conf in - S.test_traverse_pack_file `Check_index conf; - Lwt.return_unit + let () = commit_and_gc conf in + S.test_traverse_pack_file `Check_index conf end let tests = [ - Alcotest_lwt.test_case "Test index reconstruction" `Quick (fun _switch -> + Alcotest.test_case "Test index reconstruction" `Quick (fun _switch -> Test_reconstruct.test_reconstruct); - Alcotest_lwt.test_case "Test gc not allowed" `Quick (fun _switch -> + Alcotest.test_case "Test gc not allowed" `Quick (fun _switch -> Test_reconstruct.test_gc_allowed); - Alcotest_lwt.test_case "Test integrity check" `Quick (fun _switch -> + Alcotest.test_case "Test integrity check" `Quick (fun _switch -> Test_corrupted_stores.test); - Alcotest_lwt.test_case "Test integrity check minimal stores" `Quick + Alcotest.test_case "Test integrity check minimal stores" `Quick (fun _switch -> Test_corrupted_stores.test_minimal); - Alcotest_lwt.test_case "Test integrity check for inodes" `Quick + Alcotest.test_case "Test integrity check for inodes" `Quick (fun _switch -> Test_corrupted_inode.test); - Alcotest_lwt.test_case "Test traverse pack on gced store" `Quick + Alcotest.test_case "Test traverse pack on gced store" `Quick (fun _switch -> Test_traverse_gced.test_traverse_pack); ] diff --git a/test/irmin-pack/test_existing_stores.mli b/test/irmin-pack/test_existing_stores.mli index 4acc26805b..2b40d2f891 100644 --- a/test/irmin-pack/test_existing_stores.mli +++ b/test/irmin-pack/test_existing_stores.mli @@ -14,4 +14,4 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -val tests : unit Alcotest_lwt.test_case list +val tests : unit Alcotest.test_case list diff --git a/test/irmin-pack/test_flush_reload.ml b/test/irmin-pack/test_flush_reload.ml index fa15f17a75..e615d265be 100644 --- a/test/irmin-pack/test_flush_reload.ml +++ b/test/irmin-pack/test_flush_reload.ml @@ -93,19 +93,19 @@ let reload_ro t current_phase = Store.reload repo let write1_no_flush bstore nstore cstore = - let* _ = Store.put_borphan bstore in - let* _ = Store.put_c0 bstore nstore cstore in - let* _ = Store.put_c1 bstore nstore cstore in - let* _ = Store.put_borphan' bstore in - Lwt.return_unit + let _ = Store.put_borphan bstore in + let _ = Store.put_c0 bstore nstore cstore in + let _ = Store.put_c1 bstore nstore cstore in + let _ = Store.put_borphan' bstore in + () (* These tests always open both RW and RO without any data in the model. *) let start t = - let* () = start_rw t in - let* () = open_ro t S2_before_write in + let () = start_rw t in + let () = open_ro t S2_before_write in let rw = Option.get t.rw |> snd in let ro = Option.get t.ro |> snd in - Lwt.return (rw, ro) + (rw, ro) (* Open both stores. RW writes but does not flush - we do this by running the rest of the test inside the [batch]. Then reload the RO at different phases @@ -116,8 +116,7 @@ let test_one t ~(ro_reload_at : phase_flush) = if ro_reload_at = phase then reload_ro t phase; check_ro t in - let* rw, _ = start t in - let* () = + let rw, _ = start t in Store.S.Backend.Repo.batch rw (fun bstore nstore cstore -> let* () = write1_no_flush bstore nstore cstore in let () = aux S1_before_flush in @@ -129,14 +128,12 @@ let test_one t ~(ro_reload_at : phase_flush) = Store.S.Internal.( File_manager.flush ~hook (file_manager rw) |> Errs.raise_if_error) in - let () = aux S4_after_flush in - Lwt.return_unit) - in - Lwt.return_unit + aux S4_after_flush + ) let test_one_guarded setup ~ro_reload_at = let t = create_test_env setup in - let* () = test_one t ~ro_reload_at in + let () = test_one t ~ro_reload_at in close_everything t let setup = @@ -146,11 +143,11 @@ let setup = let test_flush () = let t = test_one_guarded setup in - let* () = t ~ro_reload_at:S1_before_flush in - let* () = t ~ro_reload_at:S2_after_flush_dict in - let* () = t ~ro_reload_at:S3_after_flush_suffix in - let* () = t ~ro_reload_at:S4_after_flush in - Lwt.return_unit + let () = t ~ro_reload_at:S1_before_flush in + let () = t ~ro_reload_at:S2_after_flush_dict in + let () = t ~ro_reload_at:S3_after_flush_suffix in + let () = t ~ro_reload_at:S4_after_flush in + () type phase_reload = | S1_before_reload @@ -197,10 +194,10 @@ let flush_rw t (current_phase : phase_reload) = let test_one t ~(rw_flush_at : phase_reload) = let aux phase = if rw_flush_at = phase then flush_rw t phase in - let* rw, ro = start t in + let rw, ro = start t in let reload_ro () = Store.S.Backend.Repo.batch rw (fun bstore nstore cstore -> - let* () = write1_no_flush bstore nstore cstore in + let () = write1_no_flush bstore nstore cstore in let () = aux S1_before_reload in let hook = function | `After_index -> aux S2_after_reload_index @@ -211,32 +208,29 @@ let test_one t ~(rw_flush_at : phase_reload) = Store.S.Internal.( File_manager.reload ~hook (file_manager ro) |> Errs.raise_if_error) in - let () = aux S5_after_reload in - Lwt.return_unit) + aux S5_after_reload + ) in let () = check_ro t in - let* () = reload_ro () in - let () = check_ro t in - Lwt.return_unit + let () = reload_ro () in + check_ro t let test_one_guarded setup ~rw_flush_at = let t = create_test_env setup in - let* () = test_one t ~rw_flush_at in + let () = test_one t ~rw_flush_at in close_everything t let test_reload () = let t = test_one_guarded setup in - let* () = t ~rw_flush_at:S1_before_reload in - let* () = t ~rw_flush_at:S2_after_reload_index in - let* () = t ~rw_flush_at:S3_after_reload_control in - let* () = t ~rw_flush_at:S4_after_reload_suffix in - let* () = t ~rw_flush_at:S5_after_reload in - Lwt.return_unit + let () = t ~rw_flush_at:S1_before_reload in + let () = t ~rw_flush_at:S2_after_reload_index in + let () = t ~rw_flush_at:S3_after_reload_control in + let () = t ~rw_flush_at:S4_after_reload_suffix in + let () = t ~rw_flush_at:S5_after_reload in + () let tests = [ - Alcotest_lwt.test_case "Reload during flush stages" `Quick - (fun _switch () -> test_flush ()); - Alcotest_lwt.test_case "Flush during reload stages" `Quick - (fun _switch () -> test_reload ()); + Alcotest.test_case "Reload during flush stages" `Quick test_flush; + Alcotest.test_case "Flush during reload stages" `Quick test_reload; ] diff --git a/test/irmin-pack/test_gc.ml b/test/irmin-pack/test_gc.ml index 44d6de13c0..a5d7571efe 100644 --- a/test/irmin-pack/test_gc.ml +++ b/test/irmin-pack/test_gc.ml @@ -51,7 +51,7 @@ let create_test_env () = setup_test_env ~root_archive ~root_local_build; root_local_build -let tc name f = Alcotest_lwt.test_case name `Quick (fun _switch () -> f ()) +let tc name f = Alcotest.test_case name `Quick f module Store = struct module S = struct @@ -75,46 +75,46 @@ module Store = struct let start_gc ?(unlink = false) t commit = let commit_key = S.Commit.key commit in - let* _launched = S.Gc.start_exn ~unlink t.repo commit_key in - Lwt.return_unit + let _launched = S.Gc.start_exn ~unlink t.repo commit_key in + () let finalise_gc_with_stats t = - let* result = S.Gc.finalise_exn ~wait:true t.repo in + let result = S.Gc.finalise_exn ~wait:true t.repo in match result with | `Running -> Alcotest.fail "expected finalised gc" (* consider `Idle as success because gc can finalise during commit as well *) - | `Idle -> Lwt.return_none - | `Finalised stats -> Lwt.return_some stats + | `Idle -> None + | `Finalised stats -> Some stats let finalise_gc t = - let* _ = finalise_gc_with_stats t in - Lwt.return_unit + let _ = finalise_gc_with_stats t in + () let commit ?(info = info) t = let parents = List.map S.Commit.key t.parents in - let+ h = S.Commit.v t.repo ~info ~parents t.tree in + let h = S.Commit.v t.repo ~info ~parents t.tree in S.Tree.clear t.tree; h let set t key data = - let* tree = S.Tree.add t.tree key data in - Lwt.return { t with tree } + let tree = S.Tree.add t.tree key data in + { t with tree } let del t key = - let* tree = S.Tree.remove t.tree key in - Lwt.return { t with tree } + let tree = S.Tree.remove t.tree key in + { t with tree } let checkout t key = - let* c = S.Commit.of_hash t.repo (S.Commit.hash key) in + let c = S.Commit.of_hash t.repo (S.Commit.hash key) in match c with - | None -> Lwt.return_none + | None -> None | Some commit -> let tree = S.Commit.tree commit in - Lwt.return_some { t with tree; parents = [ commit ] } + Some { t with tree; parents = [ commit ] } let checkout_exn t key = - let* o = checkout t key in - match o with None -> Lwt.fail Not_found | Some p -> Lwt.return p + let o = checkout t key in + match o with None -> raise Not_found | Some p -> p let init ?(lru_size = 0) ?(readonly = false) ?(fresh = true) ?root ?(lower_root = None) () = @@ -123,7 +123,7 @@ module Store = struct if fresh then ( rm_dir root; Option.iter rm_dir lower_root); - let+ repo = S.Repo.v (config ~readonly ~fresh ~lru_size ~lower_root root) in + let repo = S.Repo.v (config ~readonly ~fresh ~lru_size ~lower_root root) in let tree = S.Tree.empty () in { root; repo; tree; parents = [] } @@ -131,7 +131,7 @@ module Store = struct config ~lru_size:0 ~readonly:false ~fresh:true ~lower_root:None root let init_with_config config = - let+ repo = S.Repo.v config in + let repo = S.Repo.v config in let root = Irmin_pack.Conf.root config in let tree = S.Tree.empty () in { root; repo; tree; parents = [] } @@ -140,41 +140,26 @@ module Store = struct (** Predefined commits. *) let commit_1 t = - let* t = set t [ "a"; "b" ] "Novembre" in - let* t = set t [ "a"; "c" ] "Juin" in - let+ h = commit t in + let t = set t [ "a"; "b" ] "Novembre" in + let t = set t [ "a"; "c" ] "Juin" in + let h = commit t in (t, h) let commit_2 t = - let* t = set t [ "a"; "d" ] "Mars" in - let+ h = commit t in + let t = set t [ "a"; "d" ] "Mars" in + let h = commit t in (t, h) let commit_3 t = - let* t = set t [ "a"; "f" ] "Fevrier" in - let+ h = commit t in - (t, h) - - let commit_4 t = - let* t = set t [ "a"; "e" ] "Mars" in - let+ h = commit t in - (t, h) - - let commit_5 t = - let* t = set t [ "e"; "a" ] "Avril" in - let+ h = commit t in - (t, h) - - let commit_del t = - let* t = del t [ "a"; "c" ] in - let+ h = commit t in + let t = set t [ "a"; "f" ] "Fevrier" in + let h = commit t in (t, h) let commit_1_different_author t = let info = S.Info.v ~author:"someone" Int64.zero in - let* t = set t [ "a"; "b" ] "Novembre" in - let* t = set t [ "a"; "c" ] "Juin" in - let+ h = commit ~info t in + let t = set t [ "a"; "b" ] "Novembre" in + let t = set t [ "a"; "c" ] "Juin" in + let h = commit ~info t in (t, h) end @@ -188,68 +173,68 @@ let lru_hits () = (** Wrappers for testing. *) let check_blob tree key expected = - let+ got = S.Tree.find tree key in + let got = S.Tree.find tree key in Alcotest.(check (option string)) "find blob" (Some expected) got let check_none tree key = - let+ got = S.Tree.find tree key in + let got = S.Tree.find tree key in Alcotest.(check (option string)) "blob not found" None got let check_tree_1 tree = - let* () = check_blob tree [ "a"; "b" ] "Novembre" in + let () = check_blob tree [ "a"; "b" ] "Novembre" in check_blob tree [ "a"; "c" ] "Juin" let check_1 t c = - S.Commit.of_key t.repo (S.Commit.key c) >>= function + S.Commit.of_key t.repo (S.Commit.key c) |> function | None -> Alcotest.fail "no hash found in repo for check_1" | Some commit -> let tree = S.Commit.tree commit in check_tree_1 tree let check_2 t c = - S.Commit.of_key t.repo (S.Commit.key c) >>= function + S.Commit.of_key t.repo (S.Commit.key c) |> function | None -> Alcotest.fail "no hash found in repo for check_2" | Some commit -> let tree = S.Commit.tree commit in - let* () = check_blob tree [ "a"; "d" ] "Mars" in + let () = check_blob tree [ "a"; "d" ] "Mars" in (* c2 always contains c1 tree in tests *) check_tree_1 tree let check_3 t c = - S.Commit.of_key t.repo (S.Commit.key c) >>= function + S.Commit.of_key t.repo (S.Commit.key c) |> function | None -> Alcotest.fail "no hash found in repo for check_3" | Some commit -> let tree = S.Commit.tree commit in check_blob tree [ "a"; "f" ] "Fevrier" let check_4 t c = - S.Commit.of_key t.repo (S.Commit.key c) >>= function + S.Commit.of_key t.repo (S.Commit.key c) |> function | None -> Alcotest.fail "no hash found in repo for check_4" | Some commit -> let tree = S.Commit.tree commit in check_blob tree [ "a"; "e" ] "Mars" let check_5 t c = - S.Commit.of_key t.repo (S.Commit.key c) >>= function + S.Commit.of_key t.repo (S.Commit.key c) |> function | None -> Alcotest.fail "no hash found in repo for check_5" | Some commit -> let tree = S.Commit.tree commit in - let* () = check_blob tree [ "e"; "a" ] "Avril" in + let () = check_blob tree [ "e"; "a" ] "Avril" in (* c5 always contains c1 and c4 trees in tests *) - let* () = check_tree_1 tree in + let () = check_tree_1 tree in check_blob tree [ "a"; "e" ] "Mars" let check_del_1 t c = - S.Commit.of_key t.repo (S.Commit.key c) >>= function + S.Commit.of_key t.repo (S.Commit.key c) |> function | None -> Alcotest.fail "no hash found in repo for check_del_1" | Some commit -> let tree = S.Commit.tree commit in check_none tree [ "a"; "c" ] let check_not_found t key msg = - let* c = S.Commit.of_hash t.repo (S.Commit.hash key) in + let c = S.Commit.of_hash t.repo (S.Commit.hash key) in match c with - | None -> Lwt.return_unit + | None -> () | Some _ -> Alcotest.failf "should not find %s" msg module type Gc_backend = sig @@ -278,18 +263,18 @@ module Gc_common (B : Gc_backend) = struct (* c1 - c2 *) (* \---- c3 *) (* gc(c3) *) - let* t = B.init () in - let* t, c1 = commit_1 t in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in - let* t = checkout_exn t c1 in - let* t, c3 = commit_3 t in + let t = B.init () in + let t, c1 = commit_1 t in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in + let t = checkout_exn t c1 in + let t, c3 = commit_3 t in [%log.debug "Gc c1, c2, keep c3"]; - let* () = start_gc t c3 in - let* () = finalise_gc t in - let* () = B.check_gced t c1 "gced c1" in - let* () = B.check_removed t c2 "gced c2" in - let* () = check_3 t c3 in + let () = start_gc t c3 in + let () = finalise_gc t in + let () = B.check_gced t c1 "gced c1" in + let () = B.check_removed t c2 "gced c2" in + let () = check_3 t c3 in S.Repo.close t.repo (** Check that calling gc twice works. *) @@ -297,82 +282,82 @@ module Gc_common (B : Gc_backend) = struct (* gc(c4) gc(c5) *) (* c1 - c2 --- c4 -------- c5 *) (* \---- c3 *) - let* t = B.init () in - let* t, c1 = commit_1 t in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in - let* t = checkout_exn t c1 in - let* t, c3 = commit_3 t in - let* t = checkout_exn t c2 in - let* t, c4 = commit_4 t in + let t = B.init () in + let t, c1 = commit_1 t in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in + let t = checkout_exn t c1 in + let t, c3 = commit_3 t in + let t = checkout_exn t c2 in + let t, c4 = commit_4 t in [%log.debug "Gc c1, c2, c3, keep c4"]; - let* () = start_gc t c4 in - let* () = finalise_gc t in - let* t = checkout_exn t c4 in - let* t, c5 = commit_5 t in - let* () = check_5 t c5 in + let () = start_gc t c4 in + let () = finalise_gc t in + let t = checkout_exn t c4 in + let t, c5 = commit_5 t in + let () = check_5 t c5 in [%log.debug "Gc c4, keep c5"]; - let* () = start_gc t c5 in - let* () = finalise_gc t in - let* () = check_5 t c5 in - let* () = B.check_gced t c1 "gced c1" in - let* () = B.check_gced t c2 "gced c2" in - let* () = B.check_removed t c3 "gced c3" in - let* () = B.check_gced t c4 "gced c4" in + let () = start_gc t c5 in + let () = finalise_gc t in + let () = check_5 t c5 in + let () = B.check_gced t c1 "gced c1" in + let () = B.check_gced t c2 "gced c2" in + let () = B.check_removed t c3 "gced c3" in + let () = B.check_gced t c4 "gced c4" in S.Repo.close t.repo (** Check that calling gc on first commit of chain keeps everything. *) let gc_keeps_all () = (* c1 - c2 - c3 *) (* gc(c1) *) - let* t = B.init () in - let* t, c1 = commit_1 t in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in - let* t = checkout_exn t c2 in - let* t, c3 = commit_3 t in + let t = B.init () in + let t, c1 = commit_1 t in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in + let t = checkout_exn t c2 in + let t, c3 = commit_3 t in [%log.debug "Keep c1, c2, c3"]; - let* () = start_gc t c1 in - let* () = finalise_gc t in - let* () = check_1 t c1 in - let* () = check_2 t c2 in - let* () = check_3 t c3 in + let () = start_gc t c1 in + let () = finalise_gc t in + let () = check_1 t c1 in + let () = check_2 t c2 in + let () = check_3 t c3 in S.Repo.close t.repo (** Check that adding back gced commits works. *) let gc_add_back () = (* c1 - c_del - c3 ------ c1 - c2 ------- c3 *) (* gc(c3) gc(c1) *) - let* t = B.init () in - let* t, c1 = commit_1 t in - let* t = checkout_exn t c1 in - let* t, c_del = commit_del t in - let* t = checkout_exn t c_del in - let* t, c3 = commit_3 t in + let t = B.init () in + let t, c1 = commit_1 t in + let t = checkout_exn t c1 in + let t, c_del = commit_del t in + let t = checkout_exn t c_del in + let t, c3 = commit_3 t in [%log.debug "Gc c1, c_del, keep c3"]; - let* () = start_gc t c3 in - let* () = finalise_gc t in - let* () = B.check_gced t c1 "gced c1" in - let* () = B.check_gced t c_del "gced c_del" in - let* () = check_3 t c3 in - let* () = check_del_1 t c3 in + let () = start_gc t c3 in + let () = finalise_gc t in + let () = B.check_gced t c1 "gced c1" in + let () = B.check_gced t c_del "gced c_del" in + let () = check_3 t c3 in + let () = check_del_1 t c3 in [%log.debug "Add back c1"]; - let* t = checkout_exn t c3 in - let* t, c1 = commit_1 t in - let* t = checkout_exn t c1 in - let* () = check_1 t c1 in - let* t, c2 = commit_2 t in - let* () = check_2 t c2 in + let t = checkout_exn t c3 in + let t, c1 = commit_1 t in + let t = checkout_exn t c1 in + let () = check_1 t c1 in + let t, c2 = commit_2 t in + let () = check_2 t c2 in [%log.debug "Gc c3, keep c1, c2"]; - let* () = start_gc t c1 in - let* () = finalise_gc t in - let* () = B.check_gced t c3 "gced c3" in - let* () = check_2 t c2 in + let () = start_gc t c1 in + let () = finalise_gc t in + let () = B.check_gced t c3 "gced c3" in + let () = check_2 t c2 in [%log.debug "Add back c3"]; - let* t = checkout_exn t c2 in - let* t, c3 = commit_3 t in - let* () = check_3 t c2 in - let* () = check_3 t c3 in + let t = checkout_exn t c2 in + let t, c3 = commit_3 t in + let () = check_3 t c2 in + let () = check_3 t c3 in S.Repo.close t.repo (** Check that gc and close work together. *) @@ -380,42 +365,42 @@ module Gc_common (B : Gc_backend) = struct (* c1 ------ c2 *) (* gc(c1) gc(c2) *) (* close close close *) - let* t = B.init () in + let t = B.init () in let store_name = t.root in - let* t, c1 = commit_1 t in - let* () = start_gc ~unlink:false t c1 in - let* () = finalise_gc t in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in - let* () = S.Repo.close t.repo in + let t, c1 = commit_1 t in + let () = start_gc ~unlink:false t c1 in + let () = finalise_gc t in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in + let () = S.Repo.close t.repo in Alcotest.(check bool) "unlink:false" true (Sys.file_exists (Filename.concat store_name "store.0.suffix")); - let* t = B.init ~readonly:true ~fresh:false ~root:store_name () in - let* () = S.Repo.close t.repo in + let t = B.init ~readonly:true ~fresh:false ~root:store_name () in + let () = S.Repo.close t.repo in Alcotest.(check bool) "RO no clean up" true (Sys.file_exists (Filename.concat store_name "store.0.suffix")); - let* t = B.init ~readonly:false ~fresh:false ~root:store_name () in - let* () = S.Repo.close t.repo in + let t = B.init ~readonly:false ~fresh:false ~root:store_name () in + let () = S.Repo.close t.repo in Alcotest.(check bool) "RW cleaned up" true (check_async_unlinked (Filename.concat store_name "store.0.prefix")); - let* t = B.init ~readonly:false ~fresh:false ~root:store_name () in - let* () = check_1 t c1 in - let* () = check_2 t c2 in - let* () = S.Repo.close t.repo in - let* t = B.init ~readonly:false ~fresh:false ~root:store_name () in + let t = B.init ~readonly:false ~fresh:false ~root:store_name () in + let () = check_1 t c1 in + let () = check_2 t c2 in + let () = S.Repo.close t.repo in + let t = B.init ~readonly:false ~fresh:false ~root:store_name () in [%log.debug "Gc c1, keep c2"]; - let* () = start_gc ~unlink:true t c2 in - let* () = finalise_gc t in - let* () = S.Repo.close t.repo in + let () = start_gc ~unlink:true t c2 in + let () = finalise_gc t in + let () = S.Repo.close t.repo in Alcotest.(check bool) "unlink:true" true (check_async_unlinked (Filename.concat store_name "store.1.suffix")); - let* t = B.init ~readonly:false ~fresh:false ~root:store_name () in - let* () = B.check_gced t c1 "gced c1" in - let* () = check_2 t c2 in + let t = B.init ~readonly:false ~fresh:false ~root:store_name () in + let () = B.check_gced t c1 "gced c1" in + let () = check_2 t c2 in S.Repo.close t.repo (** Check that gc works on a commit with two parents. *) @@ -423,17 +408,17 @@ module Gc_common (B : Gc_backend) = struct (* gc(c3) *) (* c1 - c3 *) (* c2 -/ *) - let* t = B.init () in - let* t, c1 = commit_1 t in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in + let t = B.init () in + let t, c1 = commit_1 t in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in let t = { t with parents = [ c1; c2 ] } in - let* t, c3 = commit_3 t in - let* () = start_gc t c3 in - let* () = finalise_gc t in - let* () = B.check_gced t c1 "gced c1" in - let* () = B.check_gced t c2 "gced c2" in - let* () = check_3 t c3 in + let t, c3 = commit_3 t in + let () = start_gc t c3 in + let () = finalise_gc t in + let () = B.check_gced t c1 "gced c1" in + let () = B.check_gced t c2 "gced c2" in + let () = check_3 t c3 in S.Repo.close t.repo (** Check that gc preserves and deletes commits from RO. *) @@ -442,44 +427,44 @@ module Gc_common (B : Gc_backend) = struct (* \- c2 *) (* gc(c3) gc(c4) *) (* reload reload reload reload *) - let* t = B.init () in - let* ro_t = B.init ~readonly:true ~fresh:false ~root:t.root () in - let* t, c1 = commit_1 t in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in - let* t = checkout_exn t c1 in - let* t, c3 = commit_3 t in + let t = B.init () in + let ro_t = B.init ~readonly:true ~fresh:false ~root:t.root () in + let t, c1 = commit_1 t in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in + let t = checkout_exn t c1 in + let t, c3 = commit_3 t in S.reload ro_t.repo; [%log.debug "Gc c1, c2, keeps c3"]; - let* () = start_gc t c3 in - let* () = finalise_gc t in + let () = start_gc t c3 in + let () = finalise_gc t in [%log.debug "RO finds everything before reload"]; - let* () = check_1 ro_t c1 in - let* () = check_2 ro_t c2 in - let* () = check_3 ro_t c3 in + let () = check_1 ro_t c1 in + let () = check_2 ro_t c2 in + let () = check_3 ro_t c3 in S.reload ro_t.repo; [%log.debug "commits gced for RO after reload"]; - let* () = check_3 ro_t c3 in - let* () = B.check_gced ro_t c1 "c1" in - let* () = B.check_removed ro_t c2 "c2" in - let* t = checkout_exn t c3 in - let* t, c4 = commit_4 t in - let* t = checkout_exn t c4 in - let* t, c5 = commit_5 t in + let () = check_3 ro_t c3 in + let () = B.check_gced ro_t c1 "c1" in + let () = B.check_removed ro_t c2 "c2" in + let t = checkout_exn t c3 in + let t, c4 = commit_4 t in + let t = checkout_exn t c4 in + let t, c5 = commit_5 t in S.reload ro_t.repo; [%log.debug "Gc c3, keep c4, c5"]; - let* () = start_gc t c4 in - let* () = finalise_gc t in + let () = start_gc t c4 in + let () = finalise_gc t in [%log.debug "RO finds c3, c4, c5 before reload"]; - let* () = check_3 ro_t c3 in - let* () = check_4 ro_t c4 in - let* () = check_5 ro_t c5 in + let () = check_3 ro_t c3 in + let () = check_4 ro_t c4 in + let () = check_5 ro_t c5 in S.reload ro_t.repo; [%log.debug "RO finds c4, c5 but c3 gced after reload"]; - let* () = check_4 ro_t c4 in - let* () = check_5 ro_t c5 in - let* () = B.check_gced ro_t c3 "c3" in - let* () = S.Repo.close t.repo in + let () = check_4 ro_t c4 in + let () = check_5 ro_t c5 in + let () = B.check_gced ro_t c3 "c3" in + let () = S.Repo.close t.repo in S.Repo.close ro_t.repo (** Check that RO works if reload is called after two gcs. *) @@ -487,96 +472,96 @@ module Gc_common (B : Gc_backend) = struct (* c1 ------- c2 *) (* gc(c1) gc(c2) *) (* reload *) - let* t = B.init () in - let* ro_t = B.init ~readonly:true ~fresh:false ~root:t.root () in - let* t, c1 = commit_1 t in + let t = B.init () in + let ro_t = B.init ~readonly:true ~fresh:false ~root:t.root () in + let t, c1 = commit_1 t in S.reload ro_t.repo; - let* () = start_gc t c1 in - let* () = finalise_gc t in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in - let* () = start_gc t c2 in - let* () = finalise_gc t in + let () = start_gc t c1 in + let () = finalise_gc t in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in + let () = start_gc t c2 in + let () = finalise_gc t in [%log.debug "RO finds c1, but c2 gced before reload"]; - let* () = check_1 ro_t c1 in - let* () = check_not_found ro_t c2 "c2" in + let () = check_1 ro_t c1 in + let () = check_not_found ro_t c2 "c2" in [%log.debug "RO finds c2, but c1 gced after reload"]; S.reload ro_t.repo; - let* () = check_2 ro_t c2 in - let* () = B.check_gced ro_t c1 "c1" in - let* () = S.Repo.close t.repo in + let () = check_2 ro_t c2 in + let () = B.check_gced ro_t c1 "c1" in + let () = S.Repo.close t.repo in S.Repo.close ro_t.repo (** Check that gc and close and ro work together. *) let ro_close () = - let* t = B.init () in - let* ro_t = B.init ~readonly:true ~fresh:false ~root:t.root () in - let* t, c1 = commit_1 t in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in - let* () = S.Repo.close ro_t.repo in - let* () = start_gc t c2 in - let* () = finalise_gc t in + let t = B.init () in + let ro_t = B.init ~readonly:true ~fresh:false ~root:t.root () in + let t, c1 = commit_1 t in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in + let () = S.Repo.close ro_t.repo in + let () = start_gc t c2 in + let () = finalise_gc t in [%log.debug "RO reopens is similar to a reload"]; - let* ro_t = B.init ~readonly:true ~fresh:false ~root:t.root () in - let* () = check_2 ro_t c2 in - let* () = B.check_gced ro_t c1 "gced c1" in - let* t = checkout_exn t c2 in - let* t, c3 = commit_3 t in + let ro_t = B.init ~readonly:true ~fresh:false ~root:t.root () in + let () = check_2 ro_t c2 in + let () = B.check_gced ro_t c1 "gced c1" in + let t = checkout_exn t c2 in + let t, c3 = commit_3 t in S.reload ro_t.repo; - let* () = check_3 t c3 in - let* () = check_3 ro_t c3 in - let* () = B.check_gced ro_t c1 "gced c1" in - let* () = S.Repo.close t.repo in + let () = check_3 t c3 in + let () = check_3 ro_t c3 in + let () = B.check_gced ro_t c1 "gced c1" in + let () = S.Repo.close t.repo in S.Repo.close ro_t.repo (** Check opening RO store and calling reload right after. *) let ro_reload_after_v () = - let* t = B.init () in - let* t, c1 = commit_1 t in - let* ro_t = B.init ~readonly:true ~fresh:false ~root:t.root () in + let t = B.init () in + let t, c1 = commit_1 t in + let ro_t = B.init ~readonly:true ~fresh:false ~root:t.root () in S.reload ro_t.repo; - let* () = check_1 ro_t c1 in - let* () = S.Repo.close t.repo in + let () = check_1 ro_t c1 in + let () = S.Repo.close t.repo in S.Repo.close ro_t.repo (** Check that gc works when the lru caches some objects that are delete by consequent commits. See https://github.com/mirage/irmin/issues/1920. *) let gc_lru () = let check t c = - S.Commit.of_key t.repo (S.Commit.key c) >>= function + S.Commit.of_key t.repo (S.Commit.key c) |> function | None -> Alcotest.fail "no hash found in repo" | Some commit -> let tree = S.Commit.tree commit in check_blob tree [ "a"; "b"; "c" ] "b" in - let* t = B.init ~lru_size:100 () in - let* t = set t [ "a"; "b"; "c" ] "b" in - let* c1 = commit t in - let* t = checkout_exn t c1 in - let* t = set t [ "a"; "d"; "c" ] "b" in - let* c2 = commit t in - let* t = checkout_exn t c2 in - let* t = del t [ "a"; "d"; "c" ] in - let* c3 = commit t in - let* t = checkout_exn t c3 in - let* t = set t [ "a"; "b"; "e" ] "a" in - let* c4 = commit t in - let* () = start_gc t c3 in - let* () = finalise_gc t in - let* () = check t c4 in + let t = B.init ~lru_size:100 () in + let t = set t [ "a"; "b"; "c" ] "b" in + let c1 = commit t in + let t = checkout_exn t c1 in + let t = set t [ "a"; "d"; "c" ] "b" in + let c2 = commit t in + let t = checkout_exn t c2 in + let t = del t [ "a"; "d"; "c" ] in + let c3 = commit t in + let t = checkout_exn t c3 in + let t = set t [ "a"; "b"; "e" ] "a" in + let c4 = commit t in + let () = start_gc t c3 in + let () = finalise_gc t in + let () = check t c4 in S.Repo.close t.repo (** Check that calling gc during a batch raises an error. *) let gc_during_batch () = - let* t = B.init () in - let* t, c1 = commit_1 t in - let* _ = + let t = B.init () in + let t, c1 = commit_1 t in + let _ = Alcotest.check_raises_lwt "Should not call gc in batch" (Irmin_pack_unix.Errors.Pack_error `Gc_forbidden_during_batch) (fun () -> S.Backend.Repo.batch t.repo (fun _ _ _ -> - let* () = start_gc t c1 in + let () = start_gc t c1 in finalise_gc t)) in S.Repo.close t.repo @@ -586,46 +571,46 @@ module Gc_common (B : Gc_backend) = struct (* c1 - c2 - c3 *) (* gc(c3) *) (* c1 - c2 *) - let* t = B.init () in - let* t, c1 = commit_1 t in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in - let* t = checkout_exn t c2 in - let* t, c3 = commit_3 t in + let t = B.init () in + let t, c1 = commit_1 t in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in + let t = checkout_exn t c2 in + let t, c3 = commit_3 t in [%log.debug "Keep c3 gc c1 c2"]; - let* () = start_gc t c3 in - let* () = finalise_gc t in - let* () = B.check_gced t c1 "gced c1" in - let* () = B.check_gced t c2 "gced c2" in - let* t, c1_again = + let () = start_gc t c3 in + let () = finalise_gc t in + let () = B.check_gced t c1 "gced c1" in + let () = B.check_gced t c2 "gced c2" in + let t, c1_again = commit_1 { t with tree = S.Tree.empty (); parents = [] } in Alcotest.check_repr S.Hash.t "added commit has the same hash as gced one" (S.Commit.hash c1_again) (S.Commit.hash c1); - let* () = check_1 t c1_again in - let* t = checkout_exn t c1_again in - let* t, c2_again = commit_2 t in + let () = check_1 t c1_again in + let t = checkout_exn t c1_again in + let t, c2_again = commit_2 t in Alcotest.check_repr S.Hash.t "added commit has the same hash as gced one" (S.Commit.hash c2_again) (S.Commit.hash c2); - let* () = check_2 t c2_again in - let* () = check_3 t c3 in + let () = check_2 t c2_again in + let () = check_3 t c3 in S.Repo.close t.repo let gc_similar_commits () = - let* t = B.init () in - let* t, c1 = commit_1 t in - let* () = start_gc t c1 in - let* () = finalise_gc t in - let* t = checkout_exn t c1 in - let* t, c1_again = commit_1_different_author t in - let* () = start_gc t c1_again in - let* () = finalise_gc t in - let* () = check_1 t c1_again in + let t = B.init () in + let t, c1 = commit_1 t in + let () = start_gc t c1 in + let () = finalise_gc t in + let t = checkout_exn t c1 in + let t, c1_again = commit_1_different_author t in + let () = start_gc t c1_again in + let () = finalise_gc t in + let () = check_1 t c1_again in S.Repo.close t.repo (** Check [Gc.latest_gc_target]. *) let latest_gc_target () = - let* t = B.init () in + let t = B.init () in let check_latest_gc_target expected = let got = S.Gc.latest_gc_target t.repo in match (got, expected) with @@ -636,17 +621,17 @@ module Gc_common (B : Gc_backend) = struct | _ -> Alcotest.fail "Check of oldest_live_commit failed" in - let* t, c1 = commit_1 t in - let* t = checkout_exn t c1 in + let t, c1 = commit_1 t in + let t = checkout_exn t c1 in check_latest_gc_target None; - let* t, c2 = commit_2 t in - let* () = start_gc t c2 in - let* () = finalise_gc t in + let t, c2 = commit_2 t in + let () = start_gc t c2 in + let () = finalise_gc t in check_latest_gc_target (Some c2); - let* t = checkout_exn t c2 in - let* t, c3 = commit_3 t in - let* () = start_gc t c3 in - let* () = finalise_gc t in + let t = checkout_exn t c2 in + let t, c3 = commit_3 t in + let () = start_gc t c3 in + let () = finalise_gc t in check_latest_gc_target (Some c3); S.Repo.close t.repo @@ -670,16 +655,16 @@ module Gc_common (B : Gc_backend) = struct files in - let* t = B.init () in - let* t, c1 = commit_1 t in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in - let* () = start_gc t c2 in - let* () = finalise_gc t in - let* t = checkout_exn t c2 in - let* t, c3 = commit_3 t in - let* () = start_gc t c3 in - let* stats = finalise_gc_with_stats t in + let t = B.init () in + let t, c1 = commit_1 t in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in + let () = start_gc t c2 in + let () = finalise_gc t in + let t = checkout_exn t c2 in + let t, c3 = commit_3 t in + let () = start_gc t c3 in + let stats = finalise_gc_with_stats t in check_stats (Option.get stats); S.Repo.close t.repo @@ -867,60 +852,60 @@ end module Concurrent_gc = struct (** Check that finding old objects during a gc works. *) let find_running_gc ~lru_size () = - let* t = init ~lru_size () in - let* t, c1 = commit_1 t in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in + let t = init ~lru_size () in + let t, c1 = commit_1 t in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in [%log.debug "Gc c1 keep c2"]; - let* () = start_gc t c2 in - let* () = check_1 t c1 in - let* () = check_2 t c2 in - let* () = finalise_gc t in - let* () = check_not_found t c1 "removed c1" in - let* () = check_2 t c2 in + let () = start_gc t c2 in + let () = check_1 t c1 in + let () = check_2 t c2 in + let () = finalise_gc t in + let () = check_not_found t c1 "removed c1" in + let () = check_2 t c2 in S.Repo.close t.repo (** Check adding new objects during a gc and finding them after the gc. *) let add_running_gc ~lru_size () = - let* t = init ~lru_size () in - let* t, c1 = commit_1 t in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in + let t = init ~lru_size () in + let t, c1 = commit_1 t in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in [%log.debug "Gc c1 keep c2"]; - let* () = start_gc t c2 in - let* t = checkout_exn t c2 in - let* t, c3 = commit_3 t in - let* () = finalise_gc t in - let* () = check_not_found t c1 "removed c1" in - let* () = check_2 t c2 in - let* () = check_3 t c3 in + let () = start_gc t c2 in + let t = checkout_exn t c2 in + let t, c3 = commit_3 t in + let () = finalise_gc t in + let () = check_not_found t c1 "removed c1" in + let () = check_2 t c2 in + let () = check_3 t c3 in S.Repo.close t.repo (** Check adding new objects during a gc and finding them after the gc. *) let several_gc ~lru_size () = - let* t = init ~lru_size () in - let* t, c1 = commit_1 t in - let* () = start_gc t c1 in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in - let* () = finalise_gc t in - let* () = start_gc t c2 in - let* t = checkout_exn t c2 in - let* t, c3 = commit_3 t in - let* () = finalise_gc t in - let* () = start_gc t c3 in - let* t = checkout_exn t c3 in - let* t, c4 = commit_4 t in - let* () = finalise_gc t in - let* () = start_gc t c4 in - let* t = checkout_exn t c4 in - let* t, c5 = commit_5 t in - let* () = finalise_gc t in - let* () = check_not_found t c1 "removed c1" in - let* () = check_not_found t c2 "removed c2" in - let* () = check_not_found t c3 "removed c3" in - let* () = check_4 t c4 in - let* () = check_5 t c5 in + let t = init ~lru_size () in + let t, c1 = commit_1 t in + let () = start_gc t c1 in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in + let () = finalise_gc t in + let () = start_gc t c2 in + let t = checkout_exn t c2 in + let t, c3 = commit_3 t in + let () = finalise_gc t in + let () = start_gc t c3 in + let t = checkout_exn t c3 in + let t, c4 = commit_4 t in + let () = finalise_gc t in + let () = start_gc t c4 in + let t = checkout_exn t c4 in + let t, c5 = commit_5 t in + let () = finalise_gc t in + let () = check_not_found t c1 "removed c1" in + let () = check_not_found t c2 "removed c2" in + let () = check_not_found t c3 "removed c3" in + let () = check_4 t c4 in + let () = check_5 t c5 in S.Repo.close t.repo let find_running_gc_with_lru = find_running_gc ~lru_size:100 @@ -933,74 +918,74 @@ module Concurrent_gc = struct (** Check that RO can find old objects during gc. Also that RO can still find removed objects before a call to [reload]. *) let ro_find_running_gc () = - let* t = init () in - let* ro_t = init ~readonly:true ~fresh:false ~root:t.root () in - let* t, c1 = commit_1 t in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in + let t = init () in + let ro_t = init ~readonly:true ~fresh:false ~root:t.root () in + let t, c1 = commit_1 t in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in [%log.debug "Gc c1 keep c2"]; - let* () = start_gc t c2 in + let () = start_gc t c2 in S.reload ro_t.repo; - let* () = check_1 ro_t c1 in + let () = check_1 ro_t c1 in S.reload ro_t.repo; - let* () = check_2 ro_t c2 in - let* () = finalise_gc t in - let* () = check_1 ro_t c1 in - let* () = check_2 ro_t c2 in + let () = check_2 ro_t c2 in + let () = finalise_gc t in + let () = check_1 ro_t c1 in + let () = check_2 ro_t c2 in S.reload ro_t.repo; - let* () = check_not_found ro_t c1 "removed c1" in - let* () = check_2 t c2 in - let* () = S.Repo.close t.repo in + let () = check_not_found ro_t c1 "removed c1" in + let () = check_2 t c2 in + let () = S.Repo.close t.repo in S.Repo.close ro_t.repo (** Check that RO can find objects added during gc, but only after a call to [reload]. *) let ro_add_running_gc () = - let* t = init () in - let* ro_t = init ~readonly:true ~fresh:false ~root:t.root () in - let* t, c1 = commit_1 t in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in + let t = init () in + let ro_t = init ~readonly:true ~fresh:false ~root:t.root () in + let t, c1 = commit_1 t in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in [%log.debug "Gc c1 keep c2"]; - let* () = start_gc t c2 in + let () = start_gc t c2 in S.reload ro_t.repo; - let* t = checkout_exn t c2 in - let* t, c3 = commit_3 t in + let t = checkout_exn t c2 in + let t, c3 = commit_3 t in S.reload ro_t.repo; - let* t = checkout_exn t c2 in - let* t, c4 = commit_4 t in - let* () = finalise_gc t in - let* () = check_not_found ro_t c4 "not yet loaded c4" in - let* () = check_1 ro_t c1 in - let* () = check_2 ro_t c2 in - let* () = check_3 ro_t c3 in + let t = checkout_exn t c2 in + let t, c4 = commit_4 t in + let () = finalise_gc t in + let () = check_not_found ro_t c4 "not yet loaded c4" in + let () = check_1 ro_t c1 in + let () = check_2 ro_t c2 in + let () = check_3 ro_t c3 in S.reload ro_t.repo; - let* () = check_not_found ro_t c1 "removed c1" in - let* () = check_4 ro_t c4 in - let* () = S.Repo.close t.repo in + let () = check_not_found ro_t c1 "removed c1" in + let () = check_4 ro_t c4 in + let () = S.Repo.close t.repo in S.Repo.close ro_t.repo (** Check that RO can call [reload] during a second gc, even after no reloads occured during the first gc. *) let ro_reload_after_second_gc () = - let* t = init () in - let* ro_t = init ~readonly:true ~fresh:false ~root:t.root () in - let* t, c1 = commit_1 t in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in + let t = init () in + let ro_t = init ~readonly:true ~fresh:false ~root:t.root () in + let t, c1 = commit_1 t in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in [%log.debug "Gc c1 keep c2"]; - let* () = start_gc t c2 in - let* () = finalise_gc t in - let* t = checkout_exn t c2 in - let* t, c3 = commit_3 t in + let () = start_gc t c2 in + let () = finalise_gc t in + let t = checkout_exn t c2 in + let t, c3 = commit_3 t in [%log.debug "Gc c2 keep c3"]; - let* () = start_gc t c3 in - let* () = finalise_gc t in + let () = start_gc t c3 in + let () = finalise_gc t in S.reload ro_t.repo; - let* () = check_not_found ro_t c1 "removed c1" in - let* () = check_not_found ro_t c2 "removed c2" in - let* () = check_3 t c3 in - let* () = S.Repo.close t.repo in + let () = check_not_found ro_t c1 "removed c1" in + let () = check_not_found ro_t c2 "removed c2" in + let () = check_3 t c3 in + let () = S.Repo.close t.repo in S.Repo.close ro_t.repo (** Check that calling reload in RO will clear the LRU only after GC. *) @@ -1039,64 +1024,64 @@ module Concurrent_gc = struct (** Check that calling close during a gc kills the gc without finalising it. On reopening the store, the following gc works fine. *) let close_running_gc () = - let* t = init () in - let* t, c1 = commit_1 t in - let* () = start_gc t c1 in - let* () = S.Repo.close t.repo in - let* t = init ~readonly:false ~fresh:false ~root:t.root () in - let* () = check_1 t c1 in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in - let* () = start_gc t c2 in - let* () = finalise_gc t in - let* t = checkout_exn t c2 in + let t = init () in + let t, c1 = commit_1 t in + let () = start_gc t c1 in + let () = S.Repo.close t.repo in + let t = init ~readonly:false ~fresh:false ~root:t.root () in + let () = check_1 t c1 in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in + let () = start_gc t c2 in + let () = finalise_gc t in + let t = checkout_exn t c2 in S.Repo.close t.repo (** Check that the cleanup routine in file manager deletes correct files. *) let test_cancel_cleanup () = - let* t = init () in + let t = init () in (* chunk 0, commit 1 *) - let* t, c1 = commit_1 t in + let t, c1 = commit_1 t in let () = S.split t.repo in (* chunk 1, commit 2 *) - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in let () = S.split t.repo in (* GC chunk 0 - important to have at least one GC to test the cleanup routine's usage of generation *) - let* () = start_gc t c2 in - let* () = finalise_gc t in + let () = start_gc t c2 in + let () = finalise_gc t in (* chunk 2, commit 3 *) - let* t = checkout_exn t c2 in - let* t, c3 = commit_3 t in + let t = checkout_exn t c2 in + let t, c3 = commit_3 t in let () = S.split t.repo in (* Start GC and then close repo before finalise *) - let* () = start_gc t c3 in - let* () = S.Repo.close t.repo in + let () = start_gc t c3 in + let () = S.Repo.close t.repo in (* Reopen store. If the cleanup on cancel deletes wrong files, the store will fail to open. *) - let* t = init ~readonly:false ~fresh:false ~root:t.root () in + let t = init ~readonly:false ~fresh:false ~root:t.root () in (* Check commits *) - let* () = check_not_found t c1 "removed c1" in + let () = check_not_found t c1 "removed c1" in (* commit 2 is still around because its GC was interrupted *) - let* () = check_2 t c2 in - let* () = check_3 t c3 in + let () = check_2 t c2 in + let () = check_3 t c3 in S.Repo.close t.repo (** Check starting a gc before a previous is finalised. *) let test_skip () = - let* t = init () in - let* t, c1 = commit_1 t in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in - let* () = start_gc t c2 in - let* t = checkout_exn t c2 in - let* t, c3 = commit_3 t in - let* () = start_gc t c3 in - let* () = finalise_gc t in - let* () = check_not_found t c1 "removed c1" in - let* () = check_2 t c2 in - let* () = check_3 t c3 in + let t = init () in + let t, c1 = commit_1 t in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in + let () = start_gc t c2 in + let t = checkout_exn t c2 in + let t, c3 = commit_3 t in + let () = start_gc t c3 in + let () = finalise_gc t in + let () = check_not_found t c1 "removed c1" in + let () = check_2 t c2 in + let () = check_3 t c3 in S.Repo.close t.repo let kill_gc t = @@ -1105,24 +1090,24 @@ module Concurrent_gc = struct else Alcotest.failf "running_gc missing after call to start" let test_kill_gc_and_finalise () = - let* t = init () in - let* t, c1 = commit_1 t in - let* () = start_gc t c1 in + let t = init () in + let t, c1 = commit_1 t in + let () = start_gc t c1 in let killed = kill_gc t in - let* () = + let () = if killed then Alcotest.check_raises_pack_error "Gc process killed" (function | `Gc_process_died_without_result_file _ -> true | _ -> false) (fun () -> finalise_gc t) - else Lwt.return_unit + else () in S.Repo.close t.repo let test_kill_gc_and_close () = - let* t = init () in - let* t, c1 = commit_1 t in - let* () = start_gc t c1 in + let t = init () in + let t, c1 = commit_1 t in + let () = start_gc t c1 in let _killed = kill_gc t in S.Repo.close t.repo @@ -1148,43 +1133,43 @@ end module Split = struct let two_splits () = - let* t = init () in - let* t, c1 = commit_1 t in + let t = init () in + let t, c1 = commit_1 t in let () = S.split t.repo in - let* t = checkout_exn t c1 in + let t = checkout_exn t c1 in [%log.debug "created chunk2, find in chunk1"]; - let* () = check_1 t c1 in - let* t, c2 = commit_2 t in + let () = check_1 t c1 in + let t, c2 = commit_2 t in let () = S.split t.repo in - let* t = checkout_exn t c2 in - let* t, c3 = commit_3 t in + let t = checkout_exn t c2 in + let t, c3 = commit_3 t in [%log.debug "created chunk3, find in chunk1, chunk2, chunk3"]; - let* () = check_1 t c1 in - let* () = check_2 t c2 in - let* () = check_3 t c3 in + let () = check_1 t c1 in + let () = check_2 t c2 in + let () = check_3 t c3 in S.Repo.close t.repo let ro_two_splits () = - let* t = init () in - let* ro_t = init ~readonly:true ~fresh:false ~root:t.root () in - let* t, c1 = commit_1 t in + let t = init () in + let ro_t = init ~readonly:true ~fresh:false ~root:t.root () in + let t, c1 = commit_1 t in let () = S.split t.repo in - let* t = checkout_exn t c1 in + let t = checkout_exn t c1 in [%log.debug "created chunk2, find in chunk1"]; S.reload ro_t.repo; - let* () = check_1 ro_t c1 in - let* t, c2 = commit_2 t in + let () = check_1 ro_t c1 in + let t, c2 = commit_2 t in let () = S.split t.repo in - let* t = checkout_exn t c2 in + let t = checkout_exn t c2 in S.reload ro_t.repo; - let* t, c3 = commit_3 t in + let t, c3 = commit_3 t in [%log.debug "created chunk3, find in chunk1, chunk2, chunk3"]; - let* () = check_1 t c1 in - let* () = check_2 t c2 in - let* () = check_not_found ro_t c3 "c3 is not yet reloaded" in + let () = check_1 t c1 in + let () = check_2 t c2 in + let () = check_not_found ro_t c3 "c3 is not yet reloaded" in S.reload ro_t.repo; - let* () = check_3 t c3 in - let* () = S.Repo.close t.repo in + let () = check_3 t c3 in + let () = S.Repo.close t.repo in S.Repo.close ro_t.repo let load_commit t h = @@ -1193,99 +1178,99 @@ module Split = struct | Error (`Msg s) -> Alcotest.failf "failed hash_of_string %s" s | Ok hash -> hash in - let+ commit = S.Commit.of_hash t.repo hash in + let commit = S.Commit.of_hash t.repo hash in match commit with | None -> Alcotest.failf "Commit %s not found" h | Some commit -> commit let check_preexisting_commit t = let h = "22e159de13b427226e5901defd17f0c14e744205" in - let* commit = load_commit t h in + let commit = load_commit t h in let tree = S.Commit.tree commit in - let+ got = S.Tree.find tree [ "step-n01"; "step-b01" ] in + let got = S.Tree.find tree [ "step-n01"; "step-b01" ] in Alcotest.(check (option string)) "find blob" (Some "b01") got let v3_migrated_store_splits_and_gc () = let root = create_test_env () in - let* t = init ~readonly:false ~fresh:false ~root () in - let* c0 = load_commit t "22e159de13b427226e5901defd17f0c14e744205" in - let* t, c1 = commit_1 t in + let t = init ~readonly:false ~fresh:false ~root () in + let c0 = load_commit t "22e159de13b427226e5901defd17f0c14e744205" in + let t, c1 = commit_1 t in let () = S.split t.repo in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in let () = S.split t.repo in [%log.debug "chunk0 consists of the preexisting V3 suffix and c1, chunk1 is c2"]; - let* () = check_preexisting_commit t in - let* () = check_1 t c1 in - let* () = check_2 t c2 in + let () = check_preexisting_commit t in + let () = check_1 t c1 in + let () = check_2 t c2 in [%log.debug "GC at c0"]; - let* () = start_gc ~unlink:true t c0 in - let* () = finalise_gc t in - let* () = check_preexisting_commit t in - let* () = check_1 t c1 in - let* () = check_2 t c2 in + let () = start_gc ~unlink:true t c0 in + let () = finalise_gc t in + let () = check_preexisting_commit t in + let () = check_1 t c1 in + let () = check_2 t c2 in Alcotest.(check bool) "Chunk0 still exists" true (Sys.file_exists (Filename.concat t.root "store.0.suffix")); [%log.debug "GC at c1"]; - let* () = start_gc ~unlink:true t c1 in - let* () = finalise_gc t in - let* () = check_not_found t c0 "removed c0" in - let* () = check_1 t c1 in - let* () = check_2 t c2 in + let () = start_gc ~unlink:true t c1 in + let () = finalise_gc t in + let () = check_not_found t c0 "removed c0" in + let () = check_1 t c1 in + let () = check_2 t c2 in Alcotest.(check bool) "Chunk0 removed" true (check_async_unlinked (Filename.concat t.root "store.0.suffix")); [%log.debug "GC at c2"]; - let* () = start_gc ~unlink:true t c2 in - let* () = finalise_gc t in - let* () = check_not_found t c0 "removed c0" in - let* () = check_not_found t c1 "removed c1" in - let* () = check_2 t c2 in + let () = start_gc ~unlink:true t c2 in + let () = finalise_gc t in + let () = check_not_found t c0 "removed c0" in + let () = check_not_found t c1 "removed c1" in + let () = check_2 t c2 in S.Repo.close t.repo let close_and_split () = - let* t = init () in + let t = init () in let root = t.root in - let* t, c1 = commit_1 t in + let t, c1 = commit_1 t in let () = S.split t.repo in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in [%log.debug "created chunk1, chunk2"]; - let* () = S.Repo.close t.repo in - let* t = init ~readonly:false ~fresh:false ~root () in - let* () = check_1 t c1 in - let* () = check_2 t c2 in + let () = S.Repo.close t.repo in + let t = init ~readonly:false ~fresh:false ~root () in + let () = check_1 t c1 in + let () = check_2 t c2 in let () = S.split t.repo in - let* t = checkout_exn t c2 in - let* t, c3 = commit_3 t in + let t = checkout_exn t c2 in + let t, c3 = commit_3 t in [%log.debug "created chunk3"]; - let* () = S.Repo.close t.repo in - let* t = init ~readonly:true ~fresh:false ~root () in - let* () = check_1 t c1 in - let* () = check_2 t c2 in - let* () = check_3 t c3 in + let () = S.Repo.close t.repo in + let t = init ~readonly:true ~fresh:false ~root () in + let () = check_1 t c1 in + let () = check_2 t c2 in + let () = check_3 t c3 in S.Repo.close t.repo let two_gc_then_split () = - let* t = init () in - let* t, c1 = commit_1 t in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in - let* () = start_gc t c2 in - let* () = finalise_gc t in - let* t = checkout_exn t c2 in - let* t, c3 = commit_3 t in - let* () = start_gc t c3 in - let* () = finalise_gc t in + let t = init () in + let t, c1 = commit_1 t in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in + let () = start_gc t c2 in + let () = finalise_gc t in + let t = checkout_exn t c2 in + let t, c3 = commit_3 t in + let () = start_gc t c3 in + let () = finalise_gc t in let () = S.split t.repo in - let* t = checkout_exn t c3 in - let* t, c4 = commit_4 t in - let* () = check_not_found t c1 "removed c1" in - let* () = check_not_found t c2 "removed c2" in - let* () = check_3 t c3 in - let* () = check_4 t c4 in + let t = checkout_exn t c3 in + let t, c4 = commit_4 t in + let () = check_not_found t c1 "removed c1" in + let () = check_not_found t c2 "removed c2" in + let () = check_3 t c3 in + let () = check_4 t c4 in S.Repo.close t.repo let multi_split_and_gc () = @@ -1293,94 +1278,94 @@ module Split = struct happens correctly by testing GCs on chunks past the first one. When the calculation is incorrect, exceptions are thrown when attempting to lookup keys in the store. *) - let* t = init () in - let* t, c1 = commit_1 t in + let t = init () in + let t, c1 = commit_1 t in let () = S.split t.repo in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in let () = S.split t.repo in - let* () = start_gc t c1 in - let* () = finalise_gc t in + let () = start_gc t c1 in + let () = finalise_gc t in - let* t = checkout_exn t c2 in - let* t, c3 = commit_3 t in + let t = checkout_exn t c2 in + let t, c3 = commit_3 t in let () = S.split t.repo in - let* () = start_gc t c2 in - let* () = finalise_gc t in + let () = start_gc t c2 in + let () = finalise_gc t in - let* t = checkout_exn t c3 in - let* t, c4 = commit_4 t in + let t = checkout_exn t c3 in + let t, c4 = commit_4 t in - let* () = check_not_found t c1 "removed c1" in - let* () = check_2 t c2 in - let* () = check_3 t c3 in - let* () = check_4 t c4 in + let () = check_not_found t c1 "removed c1" in + let () = check_2 t c2 in + let () = check_3 t c3 in + let () = check_4 t c4 in S.Repo.close t.repo let split_and_gc () = - let* t = init () in - let* t, c1 = commit_1 t in + let t = init () in + let t, c1 = commit_1 t in let () = S.split t.repo in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in - let* () = start_gc t c2 in - let* () = finalise_gc t in - let* () = check_2 t c2 in - let* () = check_not_found t c1 "removed c1" in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in + let () = start_gc t c2 in + let () = finalise_gc t in + let () = check_2 t c2 in + let () = check_not_found t c1 "removed c1" in S.Repo.close t.repo let another_split_and_gc () = - let* t = init () in - let* t, c1 = commit_1 t in + let t = init () in + let t, c1 = commit_1 t in let () = S.split t.repo in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in - let* () = start_gc t c1 in - let* () = finalise_gc t in - let* () = check_1 t c1 in - let* () = check_2 t c2 in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in + let () = start_gc t c1 in + let () = finalise_gc t in + let () = check_1 t c1 in + let () = check_2 t c2 in S.Repo.close t.repo let split_during_gc () = - let* t = init () in - let* t, c1 = commit_1 t in - let* () = start_gc t c1 in + let t = init () in + let t, c1 = commit_1 t in + let () = start_gc t c1 in let () = S.split t.repo in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in - let* () = finalise_gc t in - let* () = check_1 t c1 in - let* () = check_2 t c2 in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in + let () = finalise_gc t in + let () = check_1 t c1 in + let () = check_2 t c2 in S.Repo.close t.repo let commits_and_splits_during_gc () = (* This test primarily ensures that chunk num is calculated correctly by intentionally creating chunks during a GC. *) - let* t = init () in - let* t, c1 = commit_1 t in + let t = init () in + let t, c1 = commit_1 t in let () = S.split t.repo in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in - let* () = start_gc t c2 in + let () = start_gc t c2 in let () = S.split t.repo in - let* t = checkout_exn t c2 in - let* t, c3 = commit_3 t in + let t = checkout_exn t c2 in + let t, c3 = commit_3 t in let () = S.split t.repo in - let* t = checkout_exn t c3 in - let* t, c4 = commit_4 t in - - let* () = finalise_gc t in - let* () = check_not_found t c1 "removed c1" in - let* () = check_2 t c2 in - let* () = check_3 t c3 in - let* () = check_4 t c4 in + let t = checkout_exn t c3 in + let t, c4 = commit_4 t in + + let () = finalise_gc t in + let () = check_not_found t c1 "removed c1" in + let () = check_2 t c2 in + let () = check_3 t c3 in + let () = check_4 t c4 in S.Repo.close t.repo let split_always_indexed_from_v2_store () = @@ -1419,55 +1404,55 @@ module Snapshot = struct S.create_one_commit_store t.repo commit_key let snapshot_rw () = - let* t = init () in - let* t, c1 = commit_1 t in + let t = init () in + let t, c1 = commit_1 t in let root_snap = Filename.concat t.root "snap" in - let* () = export t c1 root_snap in + let () = export t c1 root_snap in [%log.debug "store works after export"]; - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in - let* () = check_1 t c1 in - let* () = check_2 t c2 in - let* () = S.Repo.close t.repo in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in + let () = check_1 t c1 in + let () = check_2 t c2 in + let () = S.Repo.close t.repo in [%log.debug "open store from import in rw"]; - let* t = init ~readonly:false ~fresh:false ~root:root_snap () in - let* t = checkout_exn t c1 in - let* () = check_1 t c1 in - let* () = check_not_found t c2 "c2 not commited yet" in - let* t, c2 = commit_2 t in - let* () = check_2 t c2 in + let t = init ~readonly:false ~fresh:false ~root:root_snap () in + let t = checkout_exn t c1 in + let () = check_1 t c1 in + let () = check_not_found t c2 "c2 not commited yet" in + let t, c2 = commit_2 t in + let () = check_2 t c2 in S.Repo.close t.repo let snapshot_import_in_ro () = - let* t = init () in - let* t, c1 = commit_1 t in + let t = init () in + let t, c1 = commit_1 t in let root_snap = Filename.concat t.root "snap" in - let* () = export t c1 root_snap in - let* () = S.Repo.close t.repo in + let () = export t c1 root_snap in + let () = S.Repo.close t.repo in [%log.debug "open store from import in ro"]; - let* t = init ~readonly:true ~fresh:false ~root:root_snap () in - let* t = checkout_exn t c1 in - let* () = check_1 t c1 in + let t = init ~readonly:true ~fresh:false ~root:root_snap () in + let t = checkout_exn t c1 in + let () = check_1 t c1 in S.Repo.close t.repo let snapshot_export_in_ro () = - let* t = init () in - let* t, c1 = commit_1 t in - let* () = S.Repo.close t.repo in + let t = init () in + let t, c1 = commit_1 t in + let () = S.Repo.close t.repo in [%log.debug "open store in readonly to export"]; - let* t = init ~readonly:false ~fresh:false ~root:t.root () in + let t = init ~readonly:false ~fresh:false ~root:t.root () in let root_snap = Filename.concat t.root "snap" in - let* () = export t c1 root_snap in + let () = export t c1 root_snap in [%log.debug "store works after export in readonly"]; - let* t = checkout_exn t c1 in - let* () = check_1 t c1 in - let* () = S.Repo.close t.repo in + let t = checkout_exn t c1 in + let () = check_1 t c1 in + let () = S.Repo.close t.repo in [%log.debug "open store from snapshot"]; - let* t = init ~readonly:false ~fresh:false ~root:root_snap () in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in - let* () = check_1 t c1 in - let* () = check_2 t c2 in + let t = init ~readonly:false ~fresh:false ~root:root_snap () in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in + let () = check_1 t c1 in + let () = check_2 t c2 in S.Repo.close t.repo (* Test creating a snapshot in an archive store for a commit that is before diff --git a/test/irmin-pack/test_gc.mli b/test/irmin-pack/test_gc.mli index adfd50df43..dc32a48cc3 100644 --- a/test/irmin-pack/test_gc.mli +++ b/test/irmin-pack/test_gc.mli @@ -15,7 +15,7 @@ *) module Gc : sig - val tests : unit Alcotest_lwt.test_case list + val tests : unit Alcotest.test_case list end module Gc_archival : sig @@ -23,15 +23,15 @@ module Gc_archival : sig end module Concurrent_gc : sig - val tests : unit Alcotest_lwt.test_case list + val tests : unit Alcotest.test_case list end module Split : sig - val tests : unit Alcotest_lwt.test_case list + val tests : unit Alcotest.test_case list end module Snapshot : sig - val tests : unit Alcotest_lwt.test_case list + val tests : unit Alcotest.test_case list end module Store : sig @@ -40,12 +40,12 @@ module Store : sig type t val config : string -> Irmin.config - val init_with_config : Irmin.config -> t Lwt.t - val close : t -> unit Lwt.t - val start_gc : ?unlink:bool -> t -> S.commit -> unit Lwt.t - val finalise_gc : t -> unit Lwt.t - val commit_1 : t -> (t * S.commit) Lwt.t - val commit_2 : t -> (t * S.commit) Lwt.t - val commit_3 : t -> (t * S.commit) Lwt.t - val checkout_exn : t -> S.commit -> t Lwt.t + val init_with_config : Irmin.config -> t + val close : t -> unit + val start_gc : ?unlink:bool -> t -> S.commit -> unit + val finalise_gc : t -> unit + val commit_1 : t -> (t * S.commit) + val commit_2 : t -> (t * S.commit) + val commit_3 : t -> (t * S.commit) + val checkout_exn : t -> S.commit -> t end diff --git a/test/irmin-pack/test_hashes.ml b/test/irmin-pack/test_hashes.ml index 62968c126e..9935f00452 100644 --- a/test/irmin-pack/test_hashes.ml +++ b/test/irmin-pack/test_hashes.ml @@ -65,24 +65,24 @@ struct let build_tree steps = let bindings = bindings steps in let tree = Tree.empty () in - let+ tree = - Lwt_list.fold_left_s (fun tree (k, v) -> Tree.add tree k v) tree bindings + let tree = + List.fold_left (fun tree (k, v) -> Tree.add tree k v) tree bindings in tree let persist_tree tree = - let* repo = Repo.v conf in - let* init_commit = + let repo = Repo.v conf in + let init_commit = Commit.v ~parents:[] ~info:Info.empty repo (Tree.singleton [ "singleton-step" ] (Bytes.of_string "singleton-val")) in let h = Commit.hash init_commit in let info = Info.v ~author:"Tezos" 0L in - let* commit = + let commit = Commit.v ~parents:[ Irmin_pack_unix.Pack_key.v_indexed h ] ~info repo tree in let tree = Commit.tree commit in - Lwt.return (repo, tree, commit) + (repo, tree, commit) let check_hardcoded_hash msg expected got = let got = (Irmin.Type.to_string Store.Hash.t) got in @@ -118,8 +118,7 @@ module Test_tezos_conf = struct in check_iter "pre_hash" pre_hash_val zero checks; Store.check_hardcoded_hash "contents hash" - "CoWHVKM5r2eiHQxhicqakkr5FwJfabahGBwCCWzRPCNPs79CoZty" h0; - Lwt.return_unit + "CoWHVKM5r2eiHQxhicqakkr5FwJfabahGBwCCWzRPCNPs79CoZty" h0 let some_steps = [ "00"; "01" ] @@ -146,9 +145,9 @@ module Test_tezos_conf = struct ("len of values", nb_steps) :: checks let inode_values_hash () = - let* tree = Store.build_tree some_steps in - let* repo, tree, _ = Store.persist_tree tree in - let* root_node = + let tree = Store.build_tree some_steps in + let repo, tree, _ = Store.persist_tree tree in + let root_node = match Store.Tree.destruct tree with | `Contents _ -> Alcotest.fail "Expected root to be node" | `Node x -> Store.to_backend_node x @@ -163,12 +162,11 @@ module Test_tezos_conf = struct check_iter "pre_hash" pre_hash_val root_node checks; Store.check_hardcoded_hash "node hash" "CoVeCU4o3dqmfdwqt2vh8LDz9X6qGbTUyLhgVvFReyzAvTf92AKx" h; - let* () = Store.Repo.close repo in - Lwt.return_unit + Store.Repo.close repo let commit_hash () = - let* tree = Store.build_tree some_steps in - let* repo, _, commit = Store.persist_tree tree in + let tree = Store.build_tree some_steps in + let repo, _, commit = Store.persist_tree tree in let commit_val = Store.to_backend_commit commit in let h = Commit.Hash.hash commit_val in let encode_bin_hash = Irmin.Type.(unstage (encode_bin Commit.Hash.t)) in @@ -211,8 +209,7 @@ module Test_tezos_conf = struct check_iter "pre_hash" pre_hash_val commit_val checks; Store.check_hardcoded_hash "commit hash" "CoW7mALEs2vue5cfTMdJfSAjNmjmALYS1YyqSsYr9siLcNEcrvAm" h; - let* () = Store.Repo.close repo in - Lwt.return_unit + Store.Repo.close repo end module Test_small_conf = struct @@ -243,9 +240,9 @@ module Test_small_conf = struct ] let inode_tree_hash () = - let* tree = Store.build_tree many_steps in - let* repo, tree, _ = Store.persist_tree tree in - let* root_node = + let tree = Store.build_tree many_steps in + let repo, tree, _ = Store.persist_tree tree in + let root_node = match Store.Tree.destruct tree with | `Contents _ -> Alcotest.fail "Expected root to be node" | `Node x -> Store.to_backend_node x @@ -261,8 +258,7 @@ module Test_small_conf = struct check_iter "pre_hash" pre_hash_val root_node checks; Store.check_hardcoded_hash "node hash" "CoWPo8s8h81q8skRqfPLTAJvq4ioFKS6rQhdRcY5nd6HQz2upwp4" h; - let* () = Store.Repo.close repo in - Lwt.return_unit + Store.Repo.close repo end module Test_V1 = struct @@ -285,8 +281,8 @@ module Test_V1 = struct let many_steps = [ "00"; "01"; "02"; "03"; "04"; "05" ] let commit_hash () = - let* tree = Store.build_tree many_steps in - let* repo, _, commit = Store.persist_tree tree in + let tree = Store.build_tree many_steps in + let repo, _, commit = Store.persist_tree tree in let commit_val = Store.to_backend_commit commit in let checks = [ @@ -306,12 +302,11 @@ module Test_V1 = struct in let encode_bin_val = Irmin.Type.(unstage (encode_bin Commit.Val.t)) in check_iter "encode_bin" encode_bin_val commit_val checks; - let* () = Store.Repo.close repo in - Lwt.return_unit + Store.Repo.close repo end let tests = - let tc name f = Alcotest_lwt.test_case name `Quick (fun _switch -> f) in + let tc name f = Alcotest.test_case name `Quick f in [ tc "contents hash" Test_tezos_conf.contents_hash; tc "inode_values hash" Test_tezos_conf.inode_values_hash; diff --git a/test/irmin-pack/test_hashes.mli b/test/irmin-pack/test_hashes.mli index 5502f37745..3e8b1f82b6 100644 --- a/test/irmin-pack/test_hashes.mli +++ b/test/irmin-pack/test_hashes.mli @@ -14,7 +14,7 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -val tests : unit Alcotest_lwt.test_case list +val tests : unit Alcotest.test_case list val check_iter : string -> diff --git a/test/irmin-pack/test_inode.ml b/test/irmin-pack/test_inode.ml index 709ed81efd..98a0b58dad 100644 --- a/test/irmin-pack/test_inode.ml +++ b/test/irmin-pack/test_inode.ml @@ -147,19 +147,18 @@ struct let store_contents = Contents_store.v ~config ~fm ~dict ~dispatcher ~lru in - let+ foo, bar = + let foo, bar = Contents_store.batch store_contents (fun writer -> - let* foo = Contents_store.add writer Contents.foo in - let* bar = Contents_store.add writer Contents.bar in - Lwt.return (foo, bar)) + let foo = Contents_store.add writer Contents.foo in + let bar = Contents_store.add writer Contents.bar in + (foo, bar)) in [%log.app "Test context constructed"]; { store; store_contents; fm; foo; bar } let close t = - File_manager.close t.fm |> Errs.raise_if_error; + File_manager.close t.fm |> Errs.raise_if_error (* closes dict, inodes and contents store. *) - Lwt.return_unit end module Context = Context_make (Inode) @@ -335,7 +334,7 @@ end let check_node msg v t = let hash = Inter.Val.hash_exn v in - let+ key = Inode.batch t.Context.store (fun i -> Inode.add i v) in + let key = Inode.batch t.Context.store (fun i -> Inode.add i v) in let hash' = Key.to_hash key in check_hash msg hash hash' @@ -347,19 +346,19 @@ let check_hardcoded_hash msg h v = (** Test add values from an empty node. *) let test_add_values ~indexing_strategy = rm_dir root; - let* t = Context.get_store ~indexing_strategy () in + let t = Context.get_store ~indexing_strategy () in let { Context.foo; bar; _ } = t in - check_node "hash empty node" (Inode.Val.empty ()) t >>= fun () -> + check_node "hash empty node" (Inode.Val.empty ()) t; let v1 = Inode.Val.add (Inode.Val.empty ()) "x" (normal foo) in let v2 = Inode.Val.add v1 "y" (normal bar) in - check_node "node x+y" v2 t >>= fun () -> + check_node "node x+y" v2 t; check_hardcoded_hash "hash v2" "d4b55db5d2d806283766354f0d7597d332156f74" v2; let v3 = Inode.Val.of_list [ ("x", normal foo); ("y", normal bar) ] in check_values "add x+y vs v x+y" v2 v3; Context.close t let test_add_values () = - let* () = test_add_values ~indexing_strategy:`always in + let () = test_add_values ~indexing_strategy:`always in test_add_values ~indexing_strategy:`minimal let integrity_check ?(stable = true) v = @@ -372,7 +371,7 @@ let integrity_check ?(stable = true) v = (** Test add to inodes. *) let test_add_inodes ~indexing_strategy = rm_dir root; - let* t = Context.get_store ~indexing_strategy () in + let t = Context.get_store ~indexing_strategy () in let { Context.foo; bar; _ } = t in let v1 = Inode.Val.of_list [ ("x", normal foo); ("y", normal bar) ] in let v2 = Inode.Val.add v1 "z" (normal foo) in @@ -400,13 +399,13 @@ let test_add_inodes ~indexing_strategy = Context.close t let test_add_inodes () = - let* () = test_add_inodes ~indexing_strategy:`always in + let () = test_add_inodes ~indexing_strategy:`always in test_add_inodes ~indexing_strategy:`minimal (** Test remove values on an empty node. *) let test_remove_values ~indexing_strategy = rm_dir root; - let* t = Context.get_store ~indexing_strategy () in + let t = Context.get_store ~indexing_strategy () in let { Context.foo; bar; _ } = t in let v1 = Inode.Val.of_list [ ("x", normal foo); ("y", normal bar) ] in let v2 = Inode.Val.remove v1 "y" in @@ -414,8 +413,7 @@ let test_remove_values ~indexing_strategy = check_values "node x obtained two ways" v2 v3; check_hardcoded_hash "hash v2" "a1996f4309ea31cc7ba2d4c81012885aa0e08789" v2; let v4 = Inode.Val.remove v2 "x" in - check_node "remove results in an empty node" (Inode.Val.empty ()) t - >>= fun () -> + check_node "remove results in an empty node" (Inode.Val.empty ()) t; let v5 = Inode.Val.remove v4 "x" in check_values "remove on an already empty node" v4 v5; check_hardcoded_hash "hash v4" "5ba93c9db0cff93f52b521d7420e43f6eda2784f" v4; @@ -423,13 +421,13 @@ let test_remove_values ~indexing_strategy = Context.close t let test_remove_values () = - let* () = test_remove_values ~indexing_strategy:`always in + let () = test_remove_values ~indexing_strategy:`always in test_remove_values ~indexing_strategy:`minimal (** Test remove and add values to go from stable to unstable inodes. *) let test_remove_inodes ~indexing_strategy = rm_dir root; - let* t = Context.get_store ~indexing_strategy () in + let t = Context.get_store ~indexing_strategy () in let { Context.foo; bar; _ } = t in let v1 = Inode.Val.of_list @@ -456,7 +454,7 @@ let test_remove_inodes ~indexing_strategy = Context.close t let test_remove_inodes () = - let* () = test_remove_inodes ~indexing_strategy:`always in + let () = test_remove_inodes ~indexing_strategy:`always in test_remove_inodes ~indexing_strategy:`minimal (** For each of the 256 possible inode trees with [depth <= 3] and @@ -505,11 +503,10 @@ let test_representation_uniqueness_maxdepth_3 () = in List.iter (fun (ss, t) -> List.iter (fun s -> f ss t s) (P.steps p)) - (P.trees p); - Lwt.return_unit + (P.trees p) let test_truncated_inodes ~indexing_strategy = - let* t = Context.get_store ~indexing_strategy () in + let t = Context.get_store ~indexing_strategy () in let { Context.foo; bar; _ } = t in let to_truncated inode = let encode, decode = @@ -572,11 +569,11 @@ let test_truncated_inodes ~indexing_strategy = Context.close t let test_truncated_inodes () = - let* () = test_truncated_inodes ~indexing_strategy:`always in + let () = test_truncated_inodes ~indexing_strategy:`always in test_truncated_inodes ~indexing_strategy:`minimal let test_intermediate_inode_as_root ~indexing_strategy = - let* t = Context.get_store ~indexing_strategy () in + let t = Context.get_store ~indexing_strategy () in let { Context.foo; bar; _ } = t in let gen_step = Inode_permutations_generator.gen_step (module Inter) in let s000, s001, s010 = @@ -586,7 +583,7 @@ let test_intermediate_inode_as_root ~indexing_strategy = Inode.Val.of_list [ (s000, normal foo); (s001, normal bar); (s010, normal foo) ] in - let* h_depth0 = Inode.batch t.store @@ fun store -> Inode.add store v0 in + let h_depth0 = Inode.batch t.store @@ fun store -> Inode.add store v0 in let (`Inode h_depth1) = match Inode.Val.pred v0 with | [ (_, (`Inode _ as pred)) ] -> pred @@ -599,8 +596,8 @@ let test_intermediate_inode_as_root ~indexing_strategy = in (* On inode with depth=0 *) - let* v = - Inode.find t.store h_depth0 >|= function + let v = + match Inode.find t.store h_depth0 with | None -> Alcotest.fail "Could not fetch inode from backend" | Some v -> v in @@ -608,11 +605,11 @@ let test_intermediate_inode_as_root ~indexing_strategy = Alcotest.fail "Failed to list entries of loaded inode"; let _ = Inode.Val.remove v s000 in let _ = Inode.Val.add v s000 (normal foo) in - let* _ = Inode.batch t.store @@ fun store -> Inode.add store v in + let _ = Inode.batch t.store @@ fun store -> Inode.add store v in (* On inode with depth=1 *) - let* v = - Inode.find t.store h_depth1 >|= function + let v = + match Inode.find t.store h_depth1 with | None -> Alcotest.fail "Could not fetch inode from backend" | Some v -> v in @@ -626,12 +623,7 @@ let test_intermediate_inode_as_root ~indexing_strategy = in with_exn (fun () -> Inode.Val.remove v s000); with_exn (fun () -> Inode.Val.add v s000 (normal foo)); - let* () = - Inode.batch t.store (fun store -> - with_exn (fun () -> Inode.add store v); - Lwt.return_unit) - in - Lwt.return_unit + Inode.batch t.store (fun store -> with_exn (fun () -> Inode.add store v)) let test_invalid_depth_intermediate_inode ~indexing_strategy = let* t = Context_mock.get_store ~indexing_strategy () in @@ -672,13 +664,13 @@ let test_invalid_depth_intermediate_inode ~indexing_strategy = Lwt.return_unit let test_intermediate_inode_as_root () = - let* () = test_invalid_depth_intermediate_inode ~indexing_strategy:`always in - let* () = test_invalid_depth_intermediate_inode ~indexing_strategy:`minimal in - let* () = test_intermediate_inode_as_root ~indexing_strategy:`always in + let () = test_invalid_depth_intermediate_inode ~indexing_strategy:`always in + let () = test_invalid_depth_intermediate_inode ~indexing_strategy:`minimal in + let () = test_intermediate_inode_as_root ~indexing_strategy:`always in test_intermediate_inode_as_root ~indexing_strategy:`minimal let test_concrete_inodes ~indexing_strategy = - let* t = Context.get_store ~indexing_strategy () in + let t = Context.get_store ~indexing_strategy () in let { Context.foo; bar; _ } = t in let pp_concrete = Irmin.Type.pp_json ~minify:false Inter.Val.Concrete.t in let result_t = Irmin.Type.result Inode.Val.t Inter.Val.Concrete.error_t in @@ -751,9 +743,9 @@ let test_invalid_depth_concrete_inodes ~indexing_strategy = Lwt.return_unit let test_concrete_inodes () = - let* () = test_invalid_depth_concrete_inodes ~indexing_strategy:`always in - let* () = test_invalid_depth_concrete_inodes ~indexing_strategy:`minimal in - let* () = test_concrete_inodes ~indexing_strategy:`always in + let () = test_invalid_depth_concrete_inodes ~indexing_strategy:`always in + let () = test_invalid_depth_concrete_inodes ~indexing_strategy:`minimal in + let () = test_concrete_inodes ~indexing_strategy:`always in test_concrete_inodes ~indexing_strategy:`minimal module Inode_tezos = struct @@ -775,7 +767,7 @@ module Inode_tezos = struct let test_encode_bin_values ~indexing_strategy = rm_dir root; - let* t = S.Context.get_store ~indexing_strategy () in + let t = S.Context.get_store ~indexing_strategy () in let { S.Context.foo; _ } = t in let v = S.Inode.Val.of_list [ ("x", normal foo); ("z", normal foo) ] in let h = S.Inter.Val.hash_exn v in @@ -808,12 +800,12 @@ module Inode_tezos = struct S.Context.close t let test_encode_bin_values () = - let* () = test_encode_bin_values ~indexing_strategy:`always in + let () = test_encode_bin_values ~indexing_strategy:`always in test_encode_bin_values ~indexing_strategy:`minimal let test_encode_bin_tree ~indexing_strategy = rm_dir root; - let* t = S.Context.get_store ~indexing_strategy () in + let t = S.Context.get_store ~indexing_strategy () in let { S.Context.foo; bar; _ } = t in let v = S.Inode.Val.of_list @@ -853,7 +845,7 @@ module Inode_tezos = struct S.Context.close t let test_encode_bin_tree () = - let* () = test_encode_bin_tree ~indexing_strategy:`always in + let () = test_encode_bin_tree ~indexing_strategy:`always in test_encode_bin_tree ~indexing_strategy:`minimal end @@ -918,7 +910,7 @@ module Child_ordering = struct assert (chosen_bit = 0 || chosen_bit = 1); chosen_bit - let test_seeded_hash _switch () = + let test_seeded_hash () = let entries = Irmin_tezos.Conf.entries in let reference ~depth step = abs (Step.short_hash ~seed:depth step) mod entries @@ -935,8 +927,7 @@ module Child_ordering = struct let step = random_string 8 and depth = Random.int 10 in let expected = reference ~depth step in check_child_index __POS__ (module Order) ~expected ~step ~depth - done; - Lwt.return_unit + done let hash_bits_max_depth ~log2_entries = (* For a given [depth], the final bit of the corresponding index is at @@ -949,7 +940,7 @@ module Child_ordering = struct in aux 0 - let test_hash_bits _switch () = + let test_hash_bits () = (* [entries] is required to be a power of 2 greater than 1 and less than 2048, so we test every possible value here: *) for log2_entries = 1 to 10 do @@ -986,10 +977,9 @@ module Child_ordering = struct (module Order) ~step ~depth:(max_depth + 1) done - done; - Lwt.return_unit + done - let test_custom _switch () = + let test_custom () = let entries = 16 in let square_index ~depth step = let a = depth and b = int_of_string (Bytes.unsafe_to_string step) in @@ -999,13 +989,12 @@ module Child_ordering = struct check_child_index __POS__ (module Order) ~depth:1 ~step:"1" ~expected:1; check_child_index __POS__ (module Order) ~depth:2 ~step:"2" ~expected:4; check_child_index __POS__ (module Order) ~depth:3 ~step:"3" ~expected:9; - (); - Lwt.return_unit + () end let tests = - let tc_sync name f = Alcotest_lwt.test_case name `Quick f in - let tc name f = tc_sync name (fun _switch -> f) in + let tc_sync name f = Alcotest.test_case name `Quick f in + let tc name f = tc_sync name f in (* Test disabled because it relies on being able to serialise concrete inodes, which is not possible following the introduction of structured keys. *) let _ = tc "test truncated inodes" test_truncated_inodes in diff --git a/test/irmin-pack/test_inode.mli b/test/irmin-pack/test_inode.mli index 4acc26805b..2b40d2f891 100644 --- a/test/irmin-pack/test_inode.mli +++ b/test/irmin-pack/test_inode.mli @@ -14,4 +14,4 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -val tests : unit Alcotest_lwt.test_case list +val tests : unit Alcotest.test_case list diff --git a/test/irmin-pack/test_mapping.ml b/test/irmin-pack/test_mapping.ml index 4b93a67ce8..a5aa03c280 100644 --- a/test/irmin-pack/test_mapping.ml +++ b/test/irmin-pack/test_mapping.ml @@ -100,13 +100,12 @@ let test ~full_seg_length ~random_test_count = if subset <> [] then test subset; aux (i + 1) in - aux 0; - Lwt.return_unit + aux 0 let tests = [ - Alcotest_lwt.test_case "test mapping on small inputs" `Quick + Alcotest.test_case "test mapping on small inputs" `Quick (fun _switch () -> test ~full_seg_length:10 ~random_test_count:1000); - Alcotest_lwt.test_case "test mapping on large inputs" `Quick + Alcotest.test_case "test mapping on large inputs" `Quick (fun _switch () -> test ~full_seg_length:10000 ~random_test_count:100); ] diff --git a/test/irmin-pack/test_mapping.mli b/test/irmin-pack/test_mapping.mli index 4acc26805b..2b40d2f891 100644 --- a/test/irmin-pack/test_mapping.mli +++ b/test/irmin-pack/test_mapping.mli @@ -14,4 +14,4 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -val tests : unit Alcotest_lwt.test_case list +val tests : unit Alcotest.test_case list diff --git a/test/irmin-pack/test_nearest_leq.ml b/test/irmin-pack/test_nearest_leq.ml new file mode 100644 index 0000000000..4d1cfe35b6 --- /dev/null +++ b/test/irmin-pack/test_nearest_leq.ml @@ -0,0 +1,27 @@ +open Irmin_pack_unix + +type leq = [ `All_gt_key | `Some of int ] [@@deriving irmin ~pp ~equal] + +let leq = Alcotest.testable pp_leq equal_leq + +let test_nearest_leq () = + let arr = Array.of_list [ 1; 3; 5; 7 ] in + let get arr i = arr.(i) in + let lo, hi = (0, Array.length arr - 1) in + let nearest_leq key = Utils.nearest_leq ~arr ~get ~lo ~hi ~key in + Alcotest.(check leq) "0" (nearest_leq 0) `All_gt_key; + Alcotest.(check leq) "1" (nearest_leq 1) (`Some 0); + Alcotest.(check leq) "2" (nearest_leq 2) (`Some 0); + Alcotest.(check leq) "3" (nearest_leq 3) (`Some 1); + Alcotest.(check leq) "4" (nearest_leq 4) (`Some 1); + Alcotest.(check leq) "5" (nearest_leq 5) (`Some 2); + Alcotest.(check leq) "6" (nearest_leq 6) (`Some 2); + Alcotest.(check leq) "7" (nearest_leq 7) (`Some 3); + Alcotest.(check leq) "8" (nearest_leq 8) (`Some 3); + Alcotest.(check leq) "100" (nearest_leq 100) (`Some 3) + +let tests = + [ + Alcotest.test_case "test_nearest_leq" `Quick (fun () -> + test_nearest_leq ()); + ] diff --git a/test/irmin-pack/test_nearest_leq.mli b/test/irmin-pack/test_nearest_leq.mli index 01604e1617..d38ba9a90a 100644 --- a/test/irmin-pack/test_nearest_leq.mli +++ b/test/irmin-pack/test_nearest_leq.mli @@ -1 +1 @@ -val tests : unit Alcotest_lwt.test_case list +val tests : unit Alcotest.test_case list diff --git a/test/irmin-pack/test_pack.ml b/test/irmin-pack/test_pack.ml index 3201e91fa1..46e4e03034 100644 --- a/test/irmin-pack/test_pack.ml +++ b/test/irmin-pack/test_pack.ml @@ -41,8 +41,7 @@ let suite_pack name_suffix indexing_strategy (module Config : Irmin_pack.Conf.S) let test_dir = Irmin.Backend.Conf.find_root config |> Option.value ~default:test_dir in - rm_dir test_dir; - Lwt.return_unit + rm_dir test_dir in let clean = init in Irmin_test.Suite.create_generic_key ~name:("PACK" ^ name_suffix) @@ -177,16 +176,14 @@ module Dict = struct let tests = [ - Alcotest_lwt.test_case "dict" `Quick (fun _ () -> - Lwt.return (test_dict ())); - Alcotest_lwt.test_case "RO dict" `Quick (fun _ () -> - Lwt.return (test_readonly_dict ())); + Alcotest.test_case "dict" `Quick test_dict; + Alcotest.test_case "RO dict" `Quick test_readonly_dict; ] end module Pack = struct let test_pack () = - let* t = Context.get_rw_pack () in + let t = Context.get_rw_pack () in let x1 = "foo" in let x2 = "bar" in let x3 = "otoo" in @@ -195,36 +192,35 @@ module Pack = struct let h2 = sha1_contents x2 in let h3 = sha1_contents x3 in let h4 = sha1_contents x4 in - let* k1, k2, k3, k4 = - Pack.batch t.pack (fun w -> - Lwt_list.map_s + let k1, k2, k3, k4 = + Pack.batch t.Context.pack (fun w -> + List.map (fun (k, v) -> Pack.unsafe_add w k v) [ (h1, x1); (h2, x2); (h3, x3); (h4, x4) ]) - >|= function + |> function | [ k1; k2; k3; k4 ] -> (k1, k2, k3, k4) | _ -> assert false in let test t = - let* y1 = Pack.find t k1 >|= get in + let y1 = Pack.find t k1 |> get in Alcotest.(check string) "x1" x1 y1; - let* y3 = Pack.find t k3 >|= get in + let y3 = Pack.find t k3 |> get in Alcotest.(check string) "x3" x3 y3; - let* y2 = Pack.find t k2 >|= get in + let y2 = Pack.find t k2 |> get in Alcotest.(check string) "x2" x2 y2; - let* y4 = Pack.find t k4 >|= get in - Alcotest.(check string) "x4" x4 y4; - Lwt.return_unit + let y4 = Pack.find t k4 |> get in + Alcotest.(check string) "x4" x4 y4 in - test t.pack >>= fun () -> - let* t' = Context.get_ro_pack t.name in - test t'.pack >>= fun () -> - Context.close_pack t >>= fun () -> Context.close_pack t' + test t.pack; + let t' = Context.get_ro_pack t.name in + test t'.pack; + Context.close_pack t; Context.close_pack t' let test_readonly_pack () = - let* t = Context.get_rw_pack () in - let* t' = Context.get_ro_pack t.name in - let* () = + let t = Context.get_rw_pack () in + let t' = Context.get_ro_pack t.name in + let () = let adds l = List.map (fun (k, v) -> @@ -236,11 +232,11 @@ module Pack = struct let h1 = sha1_contents x1 in let h2 = sha1_contents x2 in let[@warning "-8"] [ _k1; k2 ] = adds [ (h1, x1); (h2, x2) ] in - let* y2 = Pack.find t'.pack k2 in + let y2 = Pack.find t'.pack k2 in Alcotest.(check (option string)) "before reload" None y2; flush t.fm; reload t'.fm; - let* y2 = Pack.find t'.pack k2 in + let y2 = Pack.find t'.pack k2 in Alcotest.(check (option string)) "after reload" (Some x2) y2; let x3 = "otoo" in let x4 = "sdadsadas" in @@ -249,91 +245,88 @@ module Pack = struct let[@warning "-8"] [ k3; _k4 ] = adds [ (h3, x3); (h4, x4) ] in flush t.fm; reload t'.fm; - let* y2 = Pack.find t'.pack k2 in + let y2 = Pack.find t'.pack k2 in Alcotest.(check (option string)) "y2" (Some x2) y2; - let* y3 = Pack.find t'.pack k3 in - Alcotest.(check (option string)) "y3" (Some x3) y3; - Lwt.return_unit + let y3 = Pack.find t'.pack k3 in + Alcotest.(check (option string)) "y3" (Some x3) y3 in - Context.close_pack t >>= fun () -> Context.close_pack t' + Context.close_pack t; Context.close_pack t' let test_close_pack_more () = (*open and close in rw*) - let* t = Context.get_rw_pack () in + let t = Context.get_rw_pack () in let x1 = "foo" in let h1 = sha1_contents x1 in let k1 = Pack.unsafe_append ~ensure_unique:true ~overcommit:false t.pack h1 x1 in flush t.fm; - Context.close_pack t >>= fun () -> + Context.close_pack t; (*open and close in ro*) - let* t1 = Context.get_ro_pack t.name in - let* y1 = Pack.find t1.pack k1 >|= get in + let t1 = Context.get_ro_pack t.name in + let y1 = Pack.find t1.pack k1 |> get in Alcotest.(check string) "x1.1" x1 y1; - Context.close_pack t1 >>= fun () -> + Context.close_pack t1; (* reopen in rw *) - let* t2 = Context.reopen_rw t.name in - let* y1 = Pack.find t2.pack k1 >|= get in + let t2 = Context.reopen_rw t.name in + let y1 = Pack.find t2.pack k1 |> get in Alcotest.(check string) "x1.2" x1 y1; (*reopen in ro *) - let* t3 = Context.get_ro_pack t.name in - let* y1 = Pack.find t3.pack k1 >|= get in + let t3 = Context.get_ro_pack t.name in + let y1 = Pack.find t3.pack k1 |> get in Alcotest.(check string) "x1.3" x1 y1; - Context.close_pack t2 >>= fun () -> Context.close_pack t3 + Context.close_pack t2; Context.close_pack t3 let test_close_pack () = - let* t = Context.get_rw_pack () in + let t = Context.get_rw_pack () in let w = t.pack in let x1 = "foo" in let x2 = "bar" in let h1 = sha1_contents x1 in let h2 = sha1_contents x2 in - let* k1, k2 = + let k1, k2 = Pack.batch w (fun w -> - Lwt_list.map_s - (fun (k, v) -> Pack.unsafe_add w k v) - [ (h1, x1); (h2, x2) ]) - >|= function + List.map (fun (k, v) -> Pack.unsafe_add w k v) [ (h1, x1); (h2, x2) ]) + |> function | [ k1; k2 ] -> (k1, k2) | _ -> assert false in - Context.close_pack t >>= fun () -> + Context.close_pack t; (*reopen in rw *) - let* t' = Context.reopen_rw t.name in - let* y2 = Pack.find t'.pack k2 >|= get in + let t' = Context.reopen_rw t.name in + let y2 = Pack.find t'.pack k2 |> get in Alcotest.(check string) "x2.1" x2 y2; - let* y1 = Pack.find t'.pack k1 >|= get in + let y1 = Pack.find t'.pack k1 |> get in Alcotest.(check string) "x1.1" x1 y1; let x3 = "toto" in let h3 = sha1_contents x3 in let k3 = Pack.unsafe_append ~ensure_unique:true ~overcommit:false t'.pack h3 x3 in - Context.close_pack t' >>= fun () -> + Context.close_pack t'; (*reopen in rw *) - let* t2 = Context.reopen_rw t.name in - let* y2 = Pack.find t2.pack k2 >|= get in + let t2 = Context.reopen_rw t.name in + let y2 = Pack.find t2.pack k2 |> get in Alcotest.(check string) "x2.2" x2 y2; - let* y3 = Pack.find t2.pack k3 >|= get in + let y3 = Pack.find t2.pack k3 |> get in Alcotest.(check string) "x3.2" x3 y3; - let* y1 = Pack.find t2.pack k1 >|= get in + let y1 = Pack.find t2.pack k1 |> get in Alcotest.(check string) "x1.2" x1 y1; - Context.close_pack t2 >>= fun () -> + Context.close_pack t2; (*reopen in ro *) - let* t' = Context.get_ro_pack t.name in - let* y1 = Pack.find t'.pack k1 >|= get in + let t' = Context.get_ro_pack t.name in + let y1 = Pack.find t'.pack k1 |> get in Alcotest.(check string) "x1.3" x1 y1; - let* y2 = Pack.find t'.pack k2 >|= get in + let y2 = Pack.find t'.pack k2 |> get in Alcotest.(check string) "x2.3" x2 y2; - Context.close_pack t' >>= fun () -> Lwt.return_unit + Context.close_pack t' (** Index can be flushed to disk independently of pack, we simulate this in the tests using [Index.filter] and [Index.flush]. Regression test for PR 1008 in which values were indexed before being reachable in pack. *) let readonly_reload_index_flush () = - let* t = Context.get_rw_pack () in - let* t' = Context.get_ro_pack t.name in + let t = Context.get_rw_pack () in + let t' = Context.get_ro_pack t.name in let test w = let x1 = "foo" in let h1 = sha1_contents x1 in @@ -341,11 +334,11 @@ module Pack = struct Pack.unsafe_append ~ensure_unique:true ~overcommit:false w h1 x1 in reload t'.fm; - let* y1 = Pack.find t'.pack k1 in + let y1 = Pack.find t'.pack k1 in Alcotest.(check (option string)) "reload before filter" None y1; Index.filter t.index (fun _ -> true); reload t'.fm; - let* y1 = Pack.find t'.pack k1 in + let y1 = Pack.find t'.pack k1 in Alcotest.(check (option string)) "reload after filter" (Some x1) y1; let x2 = "foo" in let h2 = sha1_contents x2 in @@ -353,17 +346,18 @@ module Pack = struct Pack.unsafe_append ~ensure_unique:true ~overcommit:false w h2 x2 in Index.flush t.index ~with_fsync:false |> Errs.raise_if_error; - let+ y2 = Pack.find t'.pack k2 in + let y2 = Pack.find t'.pack k2 in Alcotest.(check (option string)) "reload after flush" (Some x2) y2 in - test t.pack >>= fun () -> - Context.close_pack t >>= fun () -> Context.close_pack t' + test t.pack; + Context.close_pack t; + Context.close_pack t' let readonly_find_index_flush () = - let* t = Context.get_rw_pack () in - let* t' = Context.get_ro_pack t.name in + let t = Context.get_rw_pack () in + let t' = Context.get_ro_pack t.name in let check h x msg = - let+ y = Pack.find t'.pack h in + let y = Pack.find t'.pack h in Alcotest.(check (option string)) msg (Some x) y in let test w = @@ -374,9 +368,9 @@ module Pack = struct in flush t.fm; reload t'.fm; - check k1 x1 "find before filter" >>= fun () -> + check k1 x1 "find before filter"; Index.filter t.index (fun _ -> true); - check k1 x1 "find after filter" >>= fun () -> + check k1 x1 "find after filter"; let x2 = "bar" in let h2 = sha1_contents x2 in let k2 = @@ -384,34 +378,30 @@ module Pack = struct in flush t.fm; reload t'.fm; - check k2 x2 "find before flush" >>= fun () -> + check k2 x2 "find before flush"; let x3 = "toto" in let h3 = sha1_contents x3 in let k3 = Pack.unsafe_append ~ensure_unique:true ~overcommit:false w h3 x3 in Index.flush t.index ~with_fsync:false |> Errs.raise_if_error; - check k2 x2 "find after flush" >>= fun () -> + check k2 x2 "find after flush"; flush t.fm; reload t'.fm; check k3 x3 "find after flush new values" in - test t.pack >>= fun () -> - Context.close_pack t >>= fun () -> Context.close_pack t' + test t.pack; + Context.close_pack t; + Context.close_pack t' let tests = [ - Alcotest_lwt.test_case "pack" `Quick (fun _switch () -> test_pack ()); - Alcotest_lwt.test_case "RO pack" `Quick (fun _switch () -> - test_readonly_pack ()); - Alcotest_lwt.test_case "close" `Quick (fun _switch () -> - test_close_pack ()); - Alcotest_lwt.test_case "close readonly" `Quick (fun _switch () -> - test_close_pack_more ()); - Alcotest_lwt.test_case "readonly reload, index flush" `Quick - (fun _switch () -> readonly_reload_index_flush ()); - Alcotest_lwt.test_case "readonly find, index flush" `Quick - (fun _switch () -> readonly_find_index_flush ()); + Alcotest.test_case "pack" `Quick test_pack; + Alcotest.test_case "RO pack" `Quick test_readonly_pack; + Alcotest.test_case "close" `Quick test_close_pack; + Alcotest.test_case "close readonly" `Quick test_close_pack_more; + Alcotest.test_case "readonly reload, index flush" `Quick readonly_reload_index_flush; + Alcotest.test_case "readonly find, index flush" `Quick readonly_find_index_flush; ] end @@ -427,72 +417,71 @@ module Branch = struct let test_branch () = let branches = [ "foo"; "bar/toto"; "titi" ] in let test t = - Lwt_list.iter_s (fun k -> Branch.set t k (sha1 k)) branches >>= fun () -> - let check h = - let+ v = Branch.find t h in + List.iter (fun k -> Branch.set t k (sha1 k)) branches; + let check h () = + let v = Branch.find t h in Alcotest.(check (option hash)) h (Some (sha1 h)) v in - Lwt_list.iter_p check branches + List.map check branches |> Eio.Fiber.all in let name = Context.fresh_name "branch" in - Branch.v ~fresh:true name >>= test >>= fun () -> - Branch.v ~fresh:true name >>= test >>= fun () -> - Branch.v ~fresh:true name >>= test >>= fun () -> - let* t = Branch.v ~fresh:false name in - test t >>= fun () -> + Branch.v ~fresh:true name |> test; + Branch.v ~fresh:true name |> test; + Branch.v ~fresh:true name |> test; + let t = Branch.v ~fresh:false name in + test t; let x = sha1 "XXX" in - Branch.set t "foo" x >>= fun () -> - let* t = Branch.v ~fresh:false name in - let* v = Branch.find t "foo" in + Branch.set t "foo" x; + let t = Branch.v ~fresh:false name in + let v = Branch.find t "foo" in Alcotest.(check (option hash)) "foo" (Some x) v; - let* br = Branch.list t in + let br = Branch.list t in Alcotest.(check (slist string compare)) "branches" branches br; - Branch.remove t "foo" >>= fun () -> - let* t = Branch.v ~fresh:false name in - let* v = Branch.find t "foo" in + Branch.remove t "foo"; + let t = Branch.v ~fresh:false name in + let v = Branch.find t "foo" in Alcotest.(check (option hash)) "foo none" None v; - let* br = Branch.list t in + let br = Branch.list t in Alcotest.(check (slist string compare)) "branches" (List.filter (( <> ) "foo") branches) - br; - Lwt.return_unit + br let test_close_branch () = let branches = [ "foo"; "bar/toto"; "titi" ] in let add t = - Lwt_list.iter_s + List.iter (fun k -> [%logs.debug "k = %s, v= %a" k pp_hash (sha1 k)]; Branch.set t k (sha1 k)) branches in let test t = - let check h = - let+ v = Branch.find t h in + let check h () = + let v = Branch.find t h in Alcotest.(check (option hash)) h (Some (sha1 h)) v in - Lwt_list.iter_p check branches + List.map check branches |> Eio.Fiber.all in let name = Context.fresh_name "branch" in - let* t = Branch.v ~fresh:true name in - add t >>= fun () -> - test t >>= fun () -> - Branch.close t >>= fun () -> - let* t = Branch.v ~fresh:false ~readonly:true name in - test t >>= fun () -> - Branch.close t >>= fun () -> + let t = Branch.v ~fresh:true name in + add t; + test t; + Branch.close t; + let t = Branch.v ~fresh:false ~readonly:true name in + test t; + Branch.close t; let name = Context.fresh_name "branch" in - let* t1 = Branch.v ~fresh:true ~readonly:false name in - let* t2 = Branch.v ~fresh:false ~readonly:true name in - add t1 >>= fun () -> - Branch.close t1 >>= fun () -> test t2 + let t1 = Branch.v ~fresh:true ~readonly:false name in + let t2 = Branch.v ~fresh:false ~readonly:true name in + add t1; + Branch.close t1; + test t2 let tests = [ - Alcotest_lwt.test_case "branch" `Quick (fun _switch -> test_branch); - Alcotest_lwt.test_case "branch close" `Quick (fun _switch -> - test_close_branch); + Alcotest.test_case "branch" `Quick test_branch; + Alcotest.test_case "branch close" `Quick test_close_branch; ] end @@ -542,9 +531,9 @@ module Layout = struct let tests = [ - Alcotest_lwt.test_case "classify upper files" `Quick (fun _switch -> + Alcotest.test_case "classify upper files" `Quick (fun _switch -> test_classify_upper_filename); - Alcotest_lwt.test_case "classify volume files" `Quick (fun _switch -> + Alcotest.test_case "classify volume files" `Quick (fun _switch -> test_classify_volume_filename); ] end diff --git a/test/irmin-pack/test_pack.mli b/test/irmin-pack/test_pack.mli index 599c43edf1..e4a19a6027 100644 --- a/test/irmin-pack/test_pack.mli +++ b/test/irmin-pack/test_pack.mli @@ -15,4 +15,4 @@ *) val suite : Irmin_test.Suite.t list -val misc : (string * unit Alcotest_lwt.test_case list) list +val misc : (string * unit Alcotest.test_case list) list diff --git a/test/irmin-pack/test_pack_version_bump.ml b/test/irmin-pack/test_pack_version_bump.ml index dba67c5759..13ee4019d2 100644 --- a/test/irmin-pack/test_pack_version_bump.ml +++ b/test/irmin-pack/test_pack_version_bump.ml @@ -124,36 +124,34 @@ end (** {2 The tests} *) (** Cannot open a V1 store in RO mode. *) -let test_RO_no_migration () : unit Lwt.t = +let test_RO_no_migration () : unit = [%log.info "Executing test_RO_no_migration"]; let open With_existing_store () in assert (io_get_version ~root:tmp_dir = `V1); - let* () = - Alcotest.check_raises_lwt "open V1 store in RO" + let () = + Alcotest.check_raises "open V1 store in RO" (Irmin_pack_unix.Errors.Pack_error `Migration_needed) (fun () -> - let* repo = S.Repo.v (config ~readonly:true) in + let repo = S.Repo.v (config ~readonly:true) in S.Repo.close repo) in (* maybe the version bump is only visible after, check again *) alco_check_version ~pos:__POS__ ~expected:`V1 - ~actual:(io_get_version ~root:tmp_dir); - Lwt.return () + ~actual:(io_get_version ~root:tmp_dir) (** Open a V1 store RW mode. Even if no writes, the store migrates to V3. *) -let test_open_RW () : unit Lwt.t = +let test_open_RW () = [%log.info "Executing test_open_RW"]; let open With_existing_store () in assert (io_get_version ~root:tmp_dir = `V1); - let* repo = S.Repo.v (config ~readonly:false) in - let* () = S.Repo.close repo in + let repo = S.Repo.v (config ~readonly:false) in + let () = S.Repo.close repo in alco_check_version ~pos:__POS__ ~expected:`V3 - ~actual:(io_get_version ~root:tmp_dir); - Lwt.return () + ~actual:(io_get_version ~root:tmp_dir) let tests = - let f g _switch () = g () in - Alcotest_lwt. + let f g () = g () in + Alcotest. [ test_case "test_RO_no_migration" `Quick (f test_RO_no_migration); test_case "test_open_RW" `Quick (f test_open_RW); diff --git a/test/irmin-pack/test_pack_version_bump.mli b/test/irmin-pack/test_pack_version_bump.mli index 01604e1617..d38ba9a90a 100644 --- a/test/irmin-pack/test_pack_version_bump.mli +++ b/test/irmin-pack/test_pack_version_bump.mli @@ -1 +1 @@ -val tests : unit Alcotest_lwt.test_case list +val tests : unit Alcotest.test_case list diff --git a/test/irmin-pack/test_readonly.ml b/test/irmin-pack/test_readonly.ml index e4efb46077..5f6e24c9d2 100644 --- a/test/irmin-pack/test_readonly.ml +++ b/test/irmin-pack/test_readonly.ml @@ -36,19 +36,19 @@ let info () = S.Info.empty let open_ro_after_rw_closed () = rm_dir root; - let* rw = S.Repo.v (config ~readonly:false ~fresh:true root) in - let* t = S.main rw in + let rw = S.Repo.v (config ~readonly:false ~fresh:true root) in + let t = S.main rw in let tree = S.Tree.singleton [ "a" ] "x" in - S.set_tree_exn ~parents:[] ~info t [] tree >>= fun () -> - let* ro = S.Repo.v (config ~readonly:true ~fresh:false root) in - S.Repo.close rw >>= fun () -> - let* t = S.main ro in - let* c = S.Head.get t in - S.Commit.of_hash ro (S.Commit.hash c) >>= function + S.set_tree_exn ~parents:[] ~info t [] tree; + let ro = S.Repo.v (config ~readonly:true ~fresh:false root) in + S.Repo.close rw; + let t = S.main ro in + let c = S.Head.get t in + match S.Commit.of_hash ro (S.Commit.hash c) with | None -> Alcotest.fail "no hash" | Some commit -> let tree = S.Commit.tree commit in - let* x = S.Tree.find tree [ "a" ] in + let x = S.Tree.find tree [ "a" ] in Alcotest.(check (option string)) "RO find" (Some "x") x; S.Repo.close ro @@ -59,63 +59,65 @@ let check_binding ?msg repo commit key value = | None -> Fmt.str "Expected binding [%a ↦ %s]" Fmt.(Dump.list string) key value in - S.Commit.of_hash repo (S.Commit.hash commit) >>= function + match S.Commit.of_hash repo (S.Commit.hash commit) with | None -> Alcotest.failf "commit not found" | Some commit -> let tree = S.Commit.tree commit in - let+ x = S.Tree.find tree key in + let x = S.Tree.find tree key in Alcotest.(check (option string)) msg (Some value) x let ro_reload_after_add () = let check ro c k v = - S.Commit.of_hash ro (S.Commit.hash c) >>= function + match S.Commit.of_hash ro (S.Commit.hash c) with | None -> Alcotest.failf "commit not found" | Some commit -> let tree = S.Commit.tree commit in - let+ x = S.Tree.find tree [ k ] in + let x = S.Tree.find tree [ k ] in Alcotest.(check (option string)) "RO find" (Some v) x in rm_dir root; - let* rw = S.Repo.v (config ~readonly:false ~fresh:true root) in - let* ro = S.Repo.v (config ~readonly:true ~fresh:false root) in + let rw = S.Repo.v (config ~readonly:false ~fresh:true root) in + let ro = S.Repo.v (config ~readonly:true ~fresh:false root) in let tree = S.Tree.singleton [ "a" ] "x" in - let* c1 = S.Commit.v rw ~parents:[] ~info:(info ()) tree in + let c1 = S.Commit.v rw ~parents:[] ~info:(info ()) tree in S.reload ro; - check ro c1 "a" "x" >>= fun () -> + check ro c1 "a" "x"; let tree = S.Tree.singleton [ "a" ] "y" in - let* c2 = S.Commit.v rw ~parents:[] ~info:(info ()) tree in - check ro c1 "a" "x" >>= fun () -> - let* () = - S.Commit.of_hash ro (S.Commit.hash c2) >|= function + let c2 = S.Commit.v rw ~parents:[] ~info:(info ()) tree in + check ro c1 "a" "x"; + let () = + S.Commit.of_hash ro (S.Commit.hash c2) |> function | None -> () | Some _ -> Alcotest.failf "should not find branch by" in S.reload ro; - check ro c2 "a" "y" >>= fun () -> - S.Repo.close ro >>= fun () -> S.Repo.close rw + check ro c2 "a" "y"; + S.Repo.close ro; + S.Repo.close rw let ro_reload_after_close () = let binding f = f [ "a" ] "x" in rm_dir root; - let* rw = S.Repo.v (config ~readonly:false ~fresh:true root) in - let* ro = S.Repo.v (config ~readonly:true ~fresh:false root) in + let rw = S.Repo.v (config ~readonly:false ~fresh:true root) in + let ro = S.Repo.v (config ~readonly:true ~fresh:false root) in let tree = binding (S.Tree.singleton ?metadata:None) in - let* c1 = S.Commit.v rw ~parents:[] ~info:(info ()) tree in - S.Repo.close rw >>= fun () -> + let c1 = S.Commit.v rw ~parents:[] ~info:(info ()) tree in + S.Repo.close rw; S.reload ro; - binding (check_binding ro c1) >>= fun () -> S.Repo.close ro + binding (check_binding ro c1); + S.Repo.close ro let ro_batch () = - let* rw = S.Repo.v (config ~readonly:false ~fresh:true root) in - let* ro = S.Repo.v (config ~readonly:true ~fresh:false root) in - Alcotest.check_raises_lwt "Read-only store throws RO_not_allowed exception" + let rw = S.Repo.v (config ~readonly:false ~fresh:true root) in + let ro = S.Repo.v (config ~readonly:true ~fresh:false root) in + Alcotest.check_raises "Read-only store throws RO_not_allowed exception" Irmin_pack_unix.Errors.RO_not_allowed (fun () -> - S.Backend.Repo.batch ro (fun _ _ _ -> Lwt.return_unit)) - >>= fun () -> - S.Repo.close ro >>= fun () -> S.Repo.close rw + S.Backend.Repo.batch ro (fun _ _ _ -> ())); + S.Repo.close ro; + S.Repo.close rw let tests = - let tc name test = Alcotest_lwt.test_case name `Quick (fun _switch -> test) in + let tc name test = Alcotest.test_case name `Quick test in [ tc "Test open ro after rw closed" open_ro_after_rw_closed; tc "Test ro reload after add" ro_reload_after_add; diff --git a/test/irmin-pack/test_readonly.mli b/test/irmin-pack/test_readonly.mli index 4acc26805b..2b40d2f891 100644 --- a/test/irmin-pack/test_readonly.mli +++ b/test/irmin-pack/test_readonly.mli @@ -14,4 +14,4 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -val tests : unit Alcotest_lwt.test_case list +val tests : unit Alcotest.test_case list diff --git a/test/irmin-pack/test_snapshot.ml b/test/irmin-pack/test_snapshot.ml index 5d2517bafd..407afe6bef 100644 --- a/test/irmin-pack/test_snapshot.ml +++ b/test/irmin-pack/test_snapshot.ml @@ -66,8 +66,7 @@ let encode_with_size buf snapshot_inode = size := !size + String.length x; Buffer.add_string tmp x); set_int8 buf !size; - Buffer.add_buffer buf tmp; - Lwt.return_unit + Buffer.add_buffer buf tmp let decode_with_size rbuf = let size = get_int8 rbuf in @@ -87,25 +86,25 @@ let restore repo ?on_disk buf = if read < total then ( incr total_visited; let elt = decode_with_size rbuf in - let* key = S.Snapshot.Import.save_elt snapshot elt in + let key = S.Snapshot.Import.save_elt snapshot elt in aux (Some key)) - else Lwt.return (!total_visited, last_key) + else (!total_visited, last_key) in - let* result = aux None in + let result = aux None in S.Snapshot.Import.close snapshot repo; - Lwt.return result + result let test ~repo_export ~repo_import ?on_disk tree expected_visited = - let* commit = S.Commit.v repo_export ~parents:[] ~info tree in + let commit = S.Commit.v repo_export ~parents:[] ~info tree in let tree = S.Commit.tree commit in let root_key = S.Tree.key tree |> Option.get in let buf = Buffer.create 0 in - let* total_visited = + let total_visited = S.Snapshot.export ?on_disk repo_export (encode_with_size buf) ~root_key in Alcotest.(check int) "total visited during export" expected_visited total_visited; - let* total_visited, key = + let total_visited, key = Buffer.contents buf |> restore repo_import ?on_disk in Alcotest.(check int) @@ -116,29 +115,29 @@ let test ~repo_export ~repo_import ?on_disk tree expected_visited = | `Node key, Some key' -> check_key "snapshot key" key key' | `Contents _, _ -> Alcotest.fail "Root key should not be contents" in - Lwt.return_unit + () let tree2 () = let t = S.Tree.singleton [ "a" ] "x" in - let* t = S.Tree.add t [ "b" ] "y" in - let* t = S.Tree.add t [ "c" ] "y" in + let t = S.Tree.add t [ "b" ] "y" in + let t = S.Tree.add t [ "c" ] "y" in S.Tree.add t [ "d" ] "y" let test_in_memory ~indexing_strategy () = rm_dir root_export; rm_dir root_import; - let* repo_export = + let repo_export = S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_export) in - let* repo_import = + let repo_import = S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_import) in let test = test ~repo_export ~repo_import in let tree1 = S.Tree.singleton [ "a" ] "x" in - let* () = test tree1 2 in - let* tree2 = tree2 () in - let* () = test tree2 3 in - let* () = S.Repo.close repo_export in + let () = test tree1 2 in + let tree2 = tree2 () in + let () = test tree2 3 in + let () = S.Repo.close repo_export in S.Repo.close repo_import let test_in_memory_minimal = @@ -151,16 +150,16 @@ let test_on_disk ~indexing_strategy () = rm_dir root_export; rm_dir root_import; let index_on_disk = Filename.concat root_import "index_on_disk" in - let* repo_export = + let repo_export = S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_export) in - let* repo_import = + let repo_import = S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_import) in let test = test ~repo_export ~repo_import in - let* tree2 = tree2 () in - let* () = test ~on_disk:(`Path index_on_disk) tree2 3 in - let* () = S.Repo.close repo_export in + let tree2 = tree2 () in + let () = test ~on_disk:(`Path index_on_disk) tree2 3 in + let () = S.Repo.close repo_export in S.Repo.close repo_import let test_on_disk_minimal = @@ -171,84 +170,80 @@ let test_on_disk_always = let start_gc repo commit = let commit_key = S.Commit.key commit in - let* launched = S.Gc.start_exn ~unlink:false repo commit_key in - assert launched; - Lwt.return_unit + let launched = S.Gc.start_exn ~unlink:false repo commit_key in + assert launched let finalise_gc repo = - let* result = S.Gc.finalise_exn ~wait:true repo in + let result = S.Gc.finalise_exn ~wait:true repo in match result with | `Idle | `Running -> Alcotest.fail "expected finalised gc" - | `Finalised _ -> Lwt.return_unit + | `Finalised _ -> () let test_gc ~repo_export ~repo_import ?on_disk expected_visited = (* create the store *) - let* tree1 = + let tree1 = let t = S.Tree.singleton [ "b"; "a" ] "x0" in S.Tree.add t [ "a"; "b" ] "x1" in - let* c1 = S.Commit.v repo_export ~parents:[] ~info tree1 in + let c1 = S.Commit.v repo_export ~parents:[] ~info tree1 in let k1 = S.Commit.key c1 in - let* tree2 = S.Tree.add tree1 [ "a"; "c" ] "x2" in - let* _ = S.Commit.v repo_export ~parents:[ k1 ] ~info tree2 in - let* tree3 = - let* t = S.Tree.remove tree1 [ "a"; "b" ] in + let tree2 = S.Tree.add tree1 [ "a"; "c" ] "x2" in + let _ = S.Commit.v repo_export ~parents:[ k1 ] ~info tree2 in + let tree3 = + let t = S.Tree.remove tree1 [ "a"; "b" ] in S.Tree.add t [ "a"; "d" ] "x3" in - let* c3 = S.Commit.v repo_export ~parents:[ k1 ] ~info tree3 in + let c3 = S.Commit.v repo_export ~parents:[ k1 ] ~info tree3 in (* call gc on last commit *) - let* () = start_gc repo_export c3 in - let* () = finalise_gc repo_export in + let () = start_gc repo_export c3 in + let () = finalise_gc repo_export in let tree = S.Commit.tree c3 in let root_key = S.Tree.key tree |> Option.get in let buf = Buffer.create 0 in - let* total_visited = + let total_visited = S.Snapshot.export ?on_disk repo_export (encode_with_size buf) ~root_key in Alcotest.(check int) "total visited during export" expected_visited total_visited; - let* total_visited, key = + let total_visited, key = Buffer.contents buf |> restore repo_import ?on_disk in Alcotest.(check int) "total visited during import" expected_visited total_visited; - let () = - match (root_key, key) with - | _, None -> Alcotest.fail "No key imported" - | `Node key, Some key' -> check_key "snapshot key" key key' - | `Contents _, _ -> Alcotest.fail "Root key should not be contents" - in - Lwt.return_unit + match (root_key, key) with + | _, None -> Alcotest.fail "No key imported" + | `Node key, Some key' -> check_key "snapshot key" key key' + | `Contents _, _ -> Alcotest.fail "Root key should not be contents" let indexing_strategy = Irmin_pack.Indexing_strategy.minimal let test_gced_store_in_memory () = rm_dir root_export; rm_dir root_import; - let* repo_export = + let repo_export = S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_export) in - let* repo_import = + let repo_import = S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_import) in - let* () = test_gc ~repo_export ~repo_import 5 in - let* () = S.Repo.close repo_export in + let () = test_gc ~repo_export ~repo_import 5 in + let () = S.Repo.close repo_export in S.Repo.close repo_import let test_gced_store_on_disk () = rm_dir root_export; rm_dir root_import; let index_on_disk = Filename.concat root_import "index_on_disk" in - let* repo_export = + let repo_export = S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_export) in - let* repo_import = + let repo_import = S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_import) in - let* () = + let () = test_gc ~repo_export ~repo_import ~on_disk:(`Path index_on_disk) 5 in - let* () = S.Repo.close repo_export in + let () = S.Repo.close repo_export in S.Repo.close repo_import let test_export_import_reexport () = @@ -298,7 +293,7 @@ let test_export_import_reexport () = S.Repo.close repo_export let tests = - let tc name f = Alcotest_lwt.test_case name `Quick (fun _switch () -> f ()) in + let tc name f = Alcotest.test_case name `Quick f in [ tc "in memory minimal" test_in_memory_minimal; tc "in memory always" test_in_memory_always; diff --git a/test/irmin-pack/test_tree.ml b/test/irmin-pack/test_tree.ml index 64c0c437a2..761b2ca1b3 100644 --- a/test/irmin-pack/test_tree.ml +++ b/test/irmin-pack/test_tree.ml @@ -46,17 +46,17 @@ module Make (Conf : Irmin_pack.Conf.S) = struct type context = { repo : Store.repo; tree : Store.tree } let export_tree_to_store tree = - let* repo = Store.Repo.v (config ~fresh:true root) in - let* store = Store.empty repo in - let* () = Store.set_tree_exn ~info store [] tree in - let+ tree = Store.tree store in + let repo = Store.Repo.v (config ~fresh:true root) in + let store = Store.empty repo in + let () = Store.set_tree_exn ~info store [] tree in + let tree = Store.tree store in { repo; tree } let close { repo; _ } = Store.Repo.close repo let fold ~order t ~init ~f = Tree.fold ~order ~force:`True ~cache:false ~uniq:`False - ~contents:(fun k _v acc -> if k = [] then Lwt.return acc else f k acc) + ~contents:(fun k _v acc -> if k = [] then acc else f k acc) t init let init_bindings n = @@ -68,17 +68,17 @@ module Make (Conf : Irmin_pack.Conf.S) = struct let init_tree bindings = let tree = Tree.empty () in - let* tree = - Lwt_list.fold_left_s (fun tree (k, v) -> Tree.add tree k v) tree bindings + let tree = + List.fold_left (fun tree (k, v) -> Tree.add tree k v) tree bindings in export_tree_to_store tree let find_tree tree k = - let+ t = Tree.find_tree tree k in + let t = Tree.find_tree tree k in match t with None -> tree | Some t -> t let find tree k = - let+ _ = Tree.find tree k in + let _ = Tree.find tree k in tree let run_one tree = function @@ -95,18 +95,18 @@ module Make (Conf : Irmin_pack.Conf.S) = struct let run_disjoint ops tree = let run_one op = - let* _ = run_one tree op in - Lwt.return_unit + let _ = run_one tree op in + () in - let+ () = Lwt_list.iter_s run_one ops in + let () = List.iter run_one ops in (tree, ()) let run ops tree = - let+ tree = Lwt_list.fold_left_s run_one tree ops in + let tree = List.fold_left run_one tree ops in (tree, ()) - let proof_of_ops repo hash ops : _ Lwt.t = - let+ t, () = Store.Tree.produce_proof repo hash (run ops) in + let proof_of_ops repo hash ops : _ = + let t, () = Store.Tree.produce_proof repo hash (run ops) in t let bin_of_proof = Irmin.Type.(unstage (to_bin_string Tree.Proof.t)) @@ -122,7 +122,7 @@ let equal_ordered_slist ~msg l1 l2 = Alcotest.check_repr bindings_t msg l1 l2 let fold ~order ~force t ~init ~f = Tree.fold ~order ~force ~cache:false ~uniq:`False - ~contents:(fun k _v acc -> if k = [] then Lwt.return acc else f k acc) + ~contents:(fun k _v acc -> if k = [] then acc else f k acc) t init let equal_slist ~msg l1 l2 = @@ -181,22 +181,22 @@ let bindings steps = List.map (fun x -> ([ x ], zero)) steps let test_fold ?export_tree_to_store:(export_tree_to_store' = true) ~order bindings expected = let tree = Tree.empty () in - let* tree = - Lwt_list.fold_left_s (fun tree (k, v) -> Tree.add tree k v) tree bindings + let tree = + List.fold_left (fun tree (k, v) -> Tree.add tree k v) tree bindings in - let* close = + let close = match export_tree_to_store' with | true -> - let+ ctxt = export_tree_to_store tree in + let ctxt = export_tree_to_store tree in fun () -> close ctxt - | false -> Lwt.return Lwt.return + | false -> fun () -> () in - let* keys = + let keys = fold ~force: - (if export_tree_to_store' then `True else `False (Fun.const Lwt.return)) + (if export_tree_to_store' then `True else `False (Fun.const Fun.id)) ~order tree ~init:[] - ~f:(fun k acc -> Lwt.return (k :: acc)) + ~f:(fun k acc -> k :: acc) in let keys = List.rev keys in let msg, equal_lists = @@ -216,20 +216,19 @@ let test_fold_sorted () = let test_fold_random () = let bindings = bindings some_steps in let state = Random.State.make [| 0 |] in - let* () = test_fold ~order:(`Random state) bindings some_random_steps in + let () = test_fold ~order:(`Random state) bindings some_random_steps in let state = Random.State.make [| 1 |] in - let* () = test_fold ~order:(`Random state) bindings another_random_steps in + let () = test_fold ~order:(`Random state) bindings another_random_steps in (* Random fold order should still be respected if [~force:`False]. This is a regression test for a bug in which the fold order of in-memory nodes during a non-forcing traversal was always sorted. *) let state = Random.State.make [| 1 |] in - let* () = + let () = test_fold ~order:(`Random state) ~export_tree_to_store:false bindings another_random_steps in - - Lwt.return_unit + () let test_fold_undefined () = let bindings = bindings steps in @@ -242,39 +241,39 @@ let proof_of_bin s = let check_equivalence tree proof op = match op with | Add (k, v) -> - let* tree = Tree.add tree k v in - let+ proof = Tree.add proof k v in + let tree = Tree.add tree k v in + let proof = Tree.add proof k v in Alcotest.(check_repr Store.Hash.t) (Fmt.str "same hash add %a" Fmt.(Dump.list string) k) (Tree.hash tree) (Tree.hash proof); (tree, proof) | Del k -> - let* tree = Tree.remove tree k in - let+ proof = Tree.remove proof k in + let tree = Tree.remove tree k in + let proof = Tree.remove proof k in Alcotest.(check_repr Store.Hash.t) (Fmt.str "same hash del %a" Fmt.(Dump.list string) k) (Tree.hash tree) (Tree.hash proof); (tree, proof) | Find k -> - let* v_tree = Tree.find tree k in - let+ v_proof = Tree.find proof k in + let v_tree = Tree.find tree k in + let v_proof = Tree.find proof k in Alcotest.(check (option string)) (Fmt.str "same value at %a" Fmt.(Dump.list string) k) v_tree v_proof; (tree, proof) | Find_tree k -> - let* v_tree = Tree.find_tree tree k in - let+ v_proof = Tree.find_tree tree k in + let v_tree = Tree.find_tree tree k in + let v_proof = Tree.find_tree tree k in Alcotest.(check_repr [%typ: Store.tree option]) (Fmt.str "same tree at %a" Fmt.(Dump.list string) k) v_tree v_proof; (tree, proof) | Length (k, len_expected) -> - let* len_tree = Tree.length tree k in + let len_tree = Tree.length tree k in Alcotest.(check int) (Fmt.str "expected tree length at %a" Fmt.(Dump.list string) k) len_expected len_tree; - let+ len_proof = Tree.length proof k in + let len_proof = Tree.length proof k in Alcotest.(check int) (Fmt.str "same tree length at %a" Fmt.(Dump.list string) k) len_tree len_proof; @@ -288,7 +287,7 @@ let test_proofs ctxt ops = let hash = Tree.hash tree in (* Create a compressed parital Merle proof for ops *) - let* proof = proof_of_ops ctxt.repo (`Node key) ops in + let proof = proof_of_ops ctxt.repo (`Node key) ops in (* test encoding *) let enc = bin_of_proof proof in @@ -301,8 +300,8 @@ let test_proofs ctxt ops = Alcotest.(check_repr Store.Hash.t) "same initial hash" hash (Tree.hash tree_proof); - let* _ = - Lwt_list.fold_left_s + let _ = + List.fold_left (fun (tree, proof) op -> check_equivalence tree proof op) (tree, tree_proof) (ops @@ -318,11 +317,11 @@ let test_proofs ctxt ops = Find_tree [ "z"; "o"; "o" ]; ]) in - Lwt.return_unit + () let test_large_inode () = let bindings = bindings steps in - let* ctxt = init_tree bindings in + let ctxt = init_tree bindings in let ops = [ Add ([ "00" ], "3"); Del [ "01" ] ] in test_proofs ctxt ops @@ -334,14 +333,14 @@ let fewer_steps = let test_small_inode () = let bindings = bindings fewer_steps in - let* ctxt = init_tree bindings in + let ctxt = init_tree bindings in let ops = [ Add ([ "00" ], ""); Del [ "01" ] ] in test_proofs ctxt ops let test_length_proof () = let bindings = bindings fewer_steps in let size = List.length fewer_steps in - let* ctxt = init_tree bindings in + let ctxt = init_tree bindings in let ops = [ Length ([], size) (* initial size *); @@ -373,21 +372,21 @@ let test_length_proof () = test_proofs ctxt ops let test_deeper_proof () = - let* ctxt = + let ctxt = let tree = Tree.empty () in - let* level_one = + let level_one = let bindings = bindings fewer_steps in - Lwt_list.fold_left_s (fun tree (k, v) -> Tree.add tree k v) tree bindings + List.fold_left (fun tree (k, v) -> Tree.add tree k v) tree bindings in - let* level_two = - let* tree = Tree.add_tree tree [ "0g" ] level_one in + let level_two = + let tree = Tree.add_tree tree [ "0g" ] level_one in let bindings = bindings steps in - Lwt_list.fold_left_s (fun tree (k, v) -> Tree.add tree k v) tree bindings + List.fold_left (fun tree (k, v) -> Tree.add tree k v) tree bindings in - let* level_three = - let* tree = Tree.add_tree tree [ "1g" ] level_two in + let level_three = + let tree = Tree.add_tree tree [ "1g" ] level_two in let bindings = bindings fewer_steps in - Lwt_list.fold_left_s (fun tree (k, v) -> Tree.add tree k v) tree bindings + List.fold_left (fun tree (k, v) -> Tree.add tree k v) tree bindings in export_tree_to_store level_three in @@ -423,31 +422,31 @@ let test_large_proofs () = let compare_proofs n = let ops = ops n in - let* ctxt = init_tree bindings in + let ctxt = init_tree bindings in let key = match Tree.key ctxt.tree with Some (`Node k) -> k | _ -> assert false in - let* proof = proof_of_ops ctxt.repo (`Node key) ops in + let proof = proof_of_ops ctxt.repo (`Node key) ops in let enc_32 = bin_of_proof proof in - let* () = close ctxt in + let () = close ctxt in (* Build a proof on a large store (branching factor = 2) *) - let* ctxt = Binary.init_tree bindings in + let ctxt = Binary.init_tree bindings in let key = match Binary.Store.Tree.key ctxt.tree with | Some (`Node k) -> k | _ -> assert false in - let* proof = Binary.proof_of_ops ctxt.repo (`Node key) ops in + let proof = Binary.proof_of_ops ctxt.repo (`Node key) ops in let enc_2 = Binary.bin_of_proof proof in - let* () = Binary.close ctxt in + let () = Binary.close ctxt in - Lwt.return (n, String.length enc_32 / 1024, String.length enc_2 / 1024) + (n, String.length enc_32 / 1024, String.length enc_2 / 1024) in - let* a = compare_proofs 1 in - let* b = compare_proofs 100 in - let* c = compare_proofs 1_000 in - let+ d = compare_proofs 10_000 in + let a = compare_proofs 1 in + let b = compare_proofs 100 in + let c = compare_proofs 1_000 in + let d = compare_proofs 10_000 in List.iter (fun (n, k32, k2) -> Fmt.pr "Size of Merkle proof for %d operations:\n" n; @@ -491,17 +490,17 @@ let test_extenders () = let bindings3 = ([ "10001" ], "y") :: bindings2 in let f t = - let+ v = Custom.Tree.get t [ "00000" ] in + let v = Custom.Tree.get t [ "00000" ] in Alcotest.(check string) "00000" "x" v; (t, ()) in let check_proof bindings = - let* ctxt = Custom.init_tree bindings in + let ctxt = Custom.init_tree bindings in let key = Custom.Tree.key ctxt.tree |> Option.get in - let* p, () = Custom.Tree.produce_proof ctxt.repo key f in + let p, () = Custom.Tree.produce_proof ctxt.repo key f in [%log.debug "Verifying proof %a" pp_proof p]; - let+ r = Custom.Tree.verify_proof p f in + let r = Custom.Tree.verify_proof p f in match r with | Ok (_, ()) -> () | Error e -> @@ -509,7 +508,7 @@ let test_extenders () = (Irmin.Type.pp Custom.Tree.verifier_error_t) e in - Lwt_list.iter_s check_proof [ bindings; bindings2; bindings3 ] + List.iter check_proof [ bindings; bindings2; bindings3 ] let test_hardcoded_proof () = let bindings = @@ -523,14 +522,14 @@ let test_hardcoded_proof () = (Irmin.Type.pp P.inode_tree_t) elt in - let* ctxt = Custom.init_tree bindings in + let ctxt = Custom.init_tree bindings in let key = Custom.Tree.key ctxt.tree |> Option.get in let f t = - let+ v = Custom.Tree.get t [ "00000" ] in + let v = Custom.Tree.get t [ "00000" ] in Alcotest.(check string) "00000" "x" v; (t, ()) in - let* p, () = Custom.Tree.produce_proof ctxt.repo key f in + let p, () = Custom.Tree.produce_proof ctxt.repo key f in let state = P.state p in let check_depth_2 = function @@ -553,67 +552,59 @@ let test_hardcoded_proof () = check_depth_1 t | _ -> fail_with_tree state in - Lwt.return_unit + () let tree_of_list ls = let tree = Tree.empty () in - Lwt_list.fold_left_s (fun tree (k, v) -> Tree.add tree k v) tree ls + List.fold_left (fun tree (k, v) -> Tree.add tree k v) tree ls let test_reexport_node () = - let* tree = Store.Tree.add (Store.Tree.empty ()) [ "foo"; "a" ] "a" in - let* repo1 = Store.Repo.v (config ~fresh:true root) in - let* _ = + let tree = Store.Tree.add (Store.Tree.empty ()) [ "foo"; "a" ] "a" in + let repo1 = Store.Repo.v (config ~fresh:true root) in + let _ = Store.Backend.Repo.batch repo1 (fun c n _ -> Store.save_tree repo1 c n tree) in - let* () = Store.Repo.close repo1 in + let () = Store.Repo.close repo1 in (* Re-export the same tree using a different repo. *) - let* repo2 = Store.Repo.v (config ~fresh:false root) in - let* _ = - Alcotest.check_raises_lwt "re-export tree from another repo" + let repo2 = Store.Repo.v (config ~fresh:false root) in + let _ = + Alcotest.check_raises "re-export tree from another repo" (Failure "Can't export the node key from another repo") (fun () -> Store.Backend.Repo.batch repo2 (fun c n _ -> Store.save_tree repo2 c n tree)) in - let* () = Store.Repo.close repo2 in + let () = Store.Repo.close repo2 in (* Re-export a fresh tree using a different repo. *) - let* repo2 = Store.Repo.v (config ~fresh:false root) in - let* tree = Store.Tree.add (Store.Tree.empty ()) [ "foo"; "a" ] "a" in + let repo2 = Store.Repo.v (config ~fresh:false root) in + let tree = Store.Tree.add (Store.Tree.empty ()) [ "foo"; "a" ] "a" in let _ = Store.Tree.hash tree in - let* c1 = Store.Tree.get_tree tree [ "foo" ] in - let* _ = + let c1 = Store.Tree.get_tree tree [ "foo" ] in + let _ = Store.Backend.Repo.batch repo2 (fun c n _ -> Store.save_tree repo2 c n c1) in - let* () = + let () = match Store.Tree.destruct c1 with | `Contents _ -> Alcotest.fail "got `Contents, expected `Node" | `Node node -> - let* _v = Store.to_backend_node node in - Lwt.return_unit + let _v = Store.to_backend_node node in + () in Store.Repo.close repo2 let tests = [ - Alcotest_lwt.test_case "fold over keys in sorted order" `Quick - (fun _switch -> test_fold_sorted); - Alcotest_lwt.test_case "fold over keys in random order" `Quick - (fun _switch -> test_fold_random); - Alcotest_lwt.test_case "fold over keys in undefined order" `Quick - (fun _switch -> test_fold_undefined); - Alcotest_lwt.test_case "test Merkle proof for large inodes" `Quick - (fun _switch -> test_large_inode); - Alcotest_lwt.test_case "test Merkle proof for small inodes" `Quick - (fun _switch -> test_small_inode); - Alcotest_lwt.test_case "test Merkle proof for Tree.length" `Quick - (fun _switch -> test_length_proof); - Alcotest_lwt.test_case "test deeper Merkle proof" `Quick (fun _switch -> - test_deeper_proof); - Alcotest_lwt.test_case "test large Merkle proof" `Slow (fun _switch -> - test_large_proofs); - Alcotest_lwt.test_case "test extenders in stream proof" `Quick - (fun _switch -> test_extenders); - Alcotest_lwt.test_case "test hardcoded proof" `Quick (fun _switch -> - test_hardcoded_proof); - Alcotest_lwt.test_case "test reexport node" `Quick (fun _switch -> - test_reexport_node); + Alcotest.test_case "fold over keys in sorted order" `Quick test_fold_sorted; + Alcotest.test_case "fold over keys in random order" `Quick test_fold_random; + Alcotest.test_case "fold over keys in undefined order" `Quick + test_fold_undefined; + Alcotest.test_case "test Merkle proof for large inodes" `Quick + test_large_inode; + Alcotest.test_case "test Merkle proof for small inodes" `Quick + test_small_inode; + Alcotest.test_case "test Merkle proof for Tree.length" `Quick + test_length_proof; + Alcotest.test_case "test deeper Merkle proof" `Quick test_deeper_proof; + Alcotest.test_case "test large Merkle proof" `Slow test_large_proofs; + Alcotest.test_case "test hardcoded proof" `Quick test_hardcoded_proof; + Alcotest.test_case "test reexport node" `Quick test_reexport_node; ] diff --git a/test/irmin-pack/test_upgrade.ml b/test/irmin-pack/test_upgrade.ml index 2dac4a04f0..99bc74ebde 100644 --- a/test/irmin-pack/test_upgrade.ml +++ b/test/irmin-pack/test_upgrade.ml @@ -247,12 +247,12 @@ module Store = struct let gc repo = let k = key_of_entry c1 in - let* launched = S.Gc.start_exn ~unlink:true repo k in + let launched = S.Gc.start_exn ~unlink:true repo k in assert launched; - let* result = S.Gc.finalise_exn ~wait:true repo in + let result = S.Gc.finalise_exn ~wait:true repo in match result with | `Idle | `Running -> Alcotest.fail "expected finalised gc" - | `Finalised _ -> Lwt.return_unit + | `Finalised _ -> () let dict_find_opt (repo : S.repo) step = S.Internal.(Dict.find (dict repo) step) @@ -270,112 +270,112 @@ module Store = struct with Irmin_pack_unix.Pack_store.Invalid_read _ -> (* In RW mode, [mem] will raise an exception if the offset of the key is out of the bounds of the pack file *) - Lwt.return_false + false let put_borphan bstore = - let+ k = S.Backend.Contents.add bstore "borphan" in + let k = S.Backend.Contents.add bstore "borphan" in assert (k = key_of_entry borphan); k let put_b01 bstore = - let+ k = S.Backend.Contents.add bstore "b01" in + let k = S.Backend.Contents.add bstore "b01" in assert (k = key_of_entry b01); k let put_n01 bstore nstore = - let* k_b01 = put_b01 bstore in + let k_b01 = put_b01 bstore in let step = "step-b01" in let childs = [ (step, `Contents (k_b01, ())) ] in let n = S.Backend.Node.Val.of_list childs in - let+ k = S.Backend.Node.add nstore n in + let k = S.Backend.Node.add nstore n in assert (k = key_of_entry n01); k let put_n0 bstore nstore = - let* k_n01 = put_n01 bstore nstore in + let k_n01 = put_n01 bstore nstore in let step = "step-n01" in let childs = [ (step, `Node k_n01) ] in let n = S.Backend.Node.Val.of_list childs in - let+ k = S.Backend.Node.add nstore n in + let k = S.Backend.Node.add nstore n in assert (k = key_of_entry n0); k let put_c0 bstore nstore cstore = - let* k_n0 = put_n0 bstore nstore in + let k_n0 = put_n0 bstore nstore in let c = S.Backend.Commit.Val.v ~info:S.Info.empty ~node:k_n0 ~parents:[] in - let+ k = S.Backend.Commit.add cstore c in + let k = S.Backend.Commit.add cstore c in assert (k = key_of_entry c0); k let put_b1 bstore = - let+ k = S.Backend.Contents.add bstore "b1" in + let k = S.Backend.Contents.add bstore "b1" in k let put_n1 bstore nstore = - let* k_b1 = put_b1 bstore in + let k_b1 = put_b1 bstore in let k_n01 = key_of_entry n01 in let step = "step-b1" in let step' = "step-b01" in let childs = [ (step, `Contents (k_b1, ())); (step', `Node k_n01) ] in let n = S.Backend.Node.Val.of_list childs in - let+ k = S.Backend.Node.add nstore n in + let k = S.Backend.Node.add nstore n in assert (k = key_of_entry n1); k let put_c1 bstore nstore cstore = - let* k_n1 = put_n1 bstore nstore in + let k_n1 = put_n1 bstore nstore in let k_c0 = key_of_entry c0 in let c = S.Backend.Commit.Val.v ~info:S.Info.empty ~node:k_n1 ~parents:[ k_c0 ] in - let+ k = S.Backend.Commit.add cstore c in + let k = S.Backend.Commit.add cstore c in assert (k = key_of_entry c1); k let put_borphan' bstore = - let+ k = S.Backend.Contents.add bstore "borphan'" in + let k = S.Backend.Contents.add bstore "borphan'" in assert (k = key_of_entry borphan'); k let put_b2 bstore = - let+ k = S.Backend.Contents.add bstore "b2" in + let k = S.Backend.Contents.add bstore "b2" in assert (k = key_of_entry b2); k let put_n2 bstore nstore = - let* k_b2 = put_b2 bstore in + let k_b2 = put_b2 bstore in let step = "step-b2" in let childs = [ (step, `Contents (k_b2, ())) ] in let n = S.Backend.Node.Val.of_list childs in - let+ k = S.Backend.Node.add nstore n in + let k = S.Backend.Node.add nstore n in assert (k = key_of_entry n2); k let put_c2 bstore nstore cstore = - let* k_n2 = put_n2 bstore nstore in + let k_n2 = put_n2 bstore nstore in let k_c1 = key_of_entry c1 in let c = S.Backend.Commit.Val.v ~info:S.Info.empty ~node:k_n2 ~parents:[ k_c1 ] in - let+ k = S.Backend.Commit.add cstore c in + let k = S.Backend.Commit.add cstore c in assert (k = key_of_entry c2); k let preload repo = S.Backend.Repo.batch repo (fun bstore nstore cstore -> - let* _ = put_borphan bstore in - let* _ = put_c0 bstore nstore cstore in + let _ = put_borphan bstore in + let _ = put_c0 bstore nstore cstore in Lwt.return_unit) let write1 repo = S.Backend.Repo.batch repo (fun bstore nstore cstore -> - let* _ = put_c1 bstore nstore cstore in - let* _ = put_borphan' bstore in + let _ = put_c1 bstore nstore cstore in + let _ = put_borphan' bstore in Lwt.return_unit) let write2 repo = S.Backend.Repo.batch repo (fun bstore nstore cstore -> - let* _ = put_c2 bstore nstore cstore in + let _ = put_c2 bstore nstore cstore in Lwt.return_unit) end @@ -429,9 +429,9 @@ let check_index repo model = index_entries let check_suffix repo model = - Lwt_list.iter_s + List.iter (fun e -> - let+ got = Store.suffix_mem repo e in + let got = Store.suffix_mem repo e in let exp = Hashtbl.mem model.Model.suffix e.o in match (got, exp) with | false, false -> () @@ -445,7 +445,7 @@ let check_suffix repo model = pack_entries let check t = - Lwt_list.iter_s + List.iter (fun (model, repo) -> check_dict repo model; check_index repo model; @@ -482,7 +482,7 @@ let create_test_env setup = (** One of the 4 rw mutations *) let start_rw t = [%logs.app "*** start_rw %a" pp_setup t.setup]; - let+ rw = + let rw = match t.rw with | Some _ -> assert false | None -> @@ -495,7 +495,7 @@ let start_rw t = m | From_scratch -> Model.v t.setup in - let+ repo = + let repo = Store.v t.setup ~readonly:false ~fresh:false root_local_build in (model, repo) @@ -509,17 +509,17 @@ let write1_rw t = | None -> assert false | Some (_, repo) -> t.rw <- Some (Model.create_after_write1 t.setup, repo); - let* () = + let () = (* If the preload commit is not yet in the store, add it. Note that adding the same commit twice is not idempotent in indexing strategy minimal, therefore we need to make this distinction. *) if t.setup.start_mode = From_scratch then - let* _ = Store.preload repo in - Lwt.return_unit - else Lwt.return_unit + let _ = Store.preload repo in + () + else () in - let* _ = Store.write1 repo in - Lwt.return_unit + let _ = Store.write1 repo in + () (** One of the 4 rw mutations *) let gc_rw t = @@ -528,11 +528,11 @@ let gc_rw t = | None -> assert false | Some (_, repo) -> t.rw <- Some (Model.create_after_gc t.setup, repo); - let* () = + let () = match (t.setup.start_mode, t.setup.indexing_strategy) with | From_v2, _ | _, `always -> - let* () = - Alcotest.check_raises_lwt "GC on V2/always" + let () = + Alcotest.check_raises "GC on V2/always" (Irmin_pack_unix.Errors.Pack_error (`Gc_disallowed "Store does not support GC")) (fun () -> Store.gc repo) @@ -540,7 +540,7 @@ let gc_rw t = raise Skip_the_rest_of_that_test | (From_v3 | From_scratch | From_v3_c0_gced), `minimal -> Store.gc repo in - Lwt.return_unit + () (** One of the 4 rw mutations *) let write2_rw t = @@ -549,13 +549,13 @@ let write2_rw t = | None -> assert false | Some (_, repo) -> t.rw <- Some (Model.create_after_write2 t.setup, repo); - let* _ = Store.write2 repo in - Lwt.return_unit + let _ = Store.write2 repo in + () (** One of the 2 ro mutations *) let open_ro t current_phase = [%logs.app "*** open_ro %a, %a" pp_setup t.setup pp_phase current_phase]; - let+ ro = + let ro = match t.ro with | Some _ -> assert false | None -> @@ -577,17 +577,17 @@ let open_ro t current_phase = Model.create_after_write2 t.setup in let fail_and_skip error = - let* () = - Alcotest.check_raises_lwt "open empty/V2 store in RO" + let () = + Alcotest.check_raises "open empty/V2 store in RO" (Irmin_pack_unix.Errors.Pack_error error) (fun () -> - let* repo = + let repo = Store.v t.setup ~readonly:true ~fresh:false root_local_build in Store.close repo) in raise Skip_the_rest_of_that_test in - let+ repo = + let repo = match (t.setup.start_mode, current_phase) with | From_scratch, S1_before_start -> let missing_path = @@ -619,42 +619,39 @@ let sync_ro t current_phase = Store.reload repo let close_everything t = - Lwt_list.iter_s + List.iter (fun (_, repo) -> Store.close repo) (Option.to_list t.ro @ Option.to_list t.rw) let test_one t ~ro_open_at ~ro_sync_at = let aux phase = - let* () = check t in - let* () = if ro_open_at = phase then open_ro t phase else Lwt.return_unit in - let* () = check t in + let () = check t in + let () = if ro_open_at = phase then open_ro t phase else () in + let () = check t in if ro_sync_at = phase then sync_ro t phase; - let* () = check t in - Lwt.return_unit + check t in - let* () = aux S1_before_start in - let* () = start_rw t in - let* () = aux S2_before_write in - let* () = write1_rw t in - let* () = aux S3_before_gc in - let* () = gc_rw t in - let* () = aux S4_before_write in - let* () = write2_rw t in - let* () = aux S5_before_close in - Lwt.return_unit + let () = aux S1_before_start in + let () = start_rw t in + let () = aux S2_before_write in + let () = write1_rw t in + let () = aux S3_before_gc in + let () = gc_rw t in + let () = aux S4_before_write in + let () = write2_rw t in + aux S5_before_close let test_one_guarded setup ~ro_open_at ~ro_sync_at = let t = create_test_env setup in - Lwt.catch - (fun () -> - let* () = test_one t ~ro_open_at ~ro_sync_at in - close_everything t) - (function + try + let () = test_one t ~ro_open_at ~ro_sync_at in + close_everything t + with | Skip_the_rest_of_that_test -> [%logs.app "*** skip rest of %a" pp_setup setup]; close_everything t - | exn -> Lwt.fail exn) + | exn -> raise exn (** All possible interleaving of the ro calls (open and sync) with the rw calls (open, write1, gc and write2). *) @@ -662,52 +659,44 @@ let test start_mode indexing_strategy lru_size = let setup = { start_mode; indexing_strategy; lru_size } in let t = test_one_guarded setup in - let* () = t ~ro_open_at:S1_before_start ~ro_sync_at:S1_before_start in - let* () = t ~ro_open_at:S1_before_start ~ro_sync_at:S2_before_write in - let* () = t ~ro_open_at:S1_before_start ~ro_sync_at:S3_before_gc in - let* () = t ~ro_open_at:S1_before_start ~ro_sync_at:S4_before_write in - let* () = t ~ro_open_at:S1_before_start ~ro_sync_at:S5_before_close in + let () = t ~ro_open_at:S1_before_start ~ro_sync_at:S1_before_start in + let () = t ~ro_open_at:S1_before_start ~ro_sync_at:S2_before_write in + let () = t ~ro_open_at:S1_before_start ~ro_sync_at:S3_before_gc in + let () = t ~ro_open_at:S1_before_start ~ro_sync_at:S4_before_write in + let () = t ~ro_open_at:S1_before_start ~ro_sync_at:S5_before_close in - let* () = t ~ro_open_at:S2_before_write ~ro_sync_at:S2_before_write in - let* () = t ~ro_open_at:S2_before_write ~ro_sync_at:S3_before_gc in - let* () = t ~ro_open_at:S2_before_write ~ro_sync_at:S4_before_write in - let* () = t ~ro_open_at:S2_before_write ~ro_sync_at:S5_before_close in + let () = t ~ro_open_at:S2_before_write ~ro_sync_at:S2_before_write in + let () = t ~ro_open_at:S2_before_write ~ro_sync_at:S3_before_gc in + let () = t ~ro_open_at:S2_before_write ~ro_sync_at:S4_before_write in + let () = t ~ro_open_at:S2_before_write ~ro_sync_at:S5_before_close in - let* () = t ~ro_open_at:S3_before_gc ~ro_sync_at:S3_before_gc in - let* () = t ~ro_open_at:S3_before_gc ~ro_sync_at:S4_before_write in - let* () = t ~ro_open_at:S3_before_gc ~ro_sync_at:S5_before_close in + let () = t ~ro_open_at:S3_before_gc ~ro_sync_at:S3_before_gc in + let () = t ~ro_open_at:S3_before_gc ~ro_sync_at:S4_before_write in + let () = t ~ro_open_at:S3_before_gc ~ro_sync_at:S5_before_close in - let* () = t ~ro_open_at:S4_before_write ~ro_sync_at:S4_before_write in - let* () = t ~ro_open_at:S4_before_write ~ro_sync_at:S5_before_close in + let () = t ~ro_open_at:S4_before_write ~ro_sync_at:S4_before_write in + let () = t ~ro_open_at:S4_before_write ~ro_sync_at:S5_before_close in - let* () = t ~ro_open_at:S5_before_close ~ro_sync_at:S5_before_close in - Lwt.return_unit + let () = t ~ro_open_at:S5_before_close ~ro_sync_at:S5_before_close in + () (** Product on lru_size *) let test start_mode indexing_strategy = - let* () = test start_mode indexing_strategy 0 in - let* () = test start_mode indexing_strategy 100 in - Lwt.return_unit + test start_mode indexing_strategy 0; + test start_mode indexing_strategy 100 -let test_gced_store () = - let* () = test From_v3_c0_gced `minimal in - Lwt.return_unit +let test_gced_store () = test From_v3_c0_gced `minimal (** Product on indexing_strategy *) let test start_mode () = - let* () = test start_mode `minimal in - let* () = test start_mode `always in - Lwt.return_unit + test start_mode `minimal; + test start_mode `always (** Product on start_mode *) let tests = [ - Alcotest_lwt.test_case "upgrade From_v3" `Quick (fun _switch () -> - test From_v3 ()); - Alcotest_lwt.test_case "upgrade From_v2" `Quick (fun _switch () -> - test From_v2 ()); - Alcotest_lwt.test_case "upgrade From_scratch" `Quick (fun _switch () -> - test From_scratch ()); - Alcotest_lwt.test_case "upgrade From_v3 after Gc" `Quick (fun _switch () -> - test_gced_store ()); + Alcotest.test_case "upgrade From_v3" `Quick (test From_v3); + Alcotest.test_case "upgrade From_v2" `Quick (test From_v2); + Alcotest.test_case "upgrade From_scratch" `Quick (test From_scratch); + Alcotest.test_case "upgrade From_v3 after Gc" `Quick test_gced_store; ] From 4eb665f8da24554b7b9e2cd1034c08ea6c4c626d Mon Sep 17 00:00:00 2001 From: Patrick Ferris Date: Fri, 2 Sep 2022 19:32:47 +0100 Subject: [PATCH 06/99] Update to latest eio --- src/irmin-fs/irmin_fs.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/irmin-fs/irmin_fs.ml b/src/irmin-fs/irmin_fs.ml index 01965b3862..8dba10edab 100644 --- a/src/irmin-fs/irmin_fs.ml +++ b/src/irmin-fs/irmin_fs.ml @@ -346,7 +346,7 @@ module IO_mem = struct l let with_lock l f = - match l with None -> f () | Some l -> Eio.Mutex.with_lock l f + match l with None -> f () | Some l -> Eio.Mutex.use_rw ~protect:false l f let set_listen_hook () = let h _ dir f = From e9088a5b07da1902e4793d8b33fb6be2c5d84b00 Mon Sep 17 00:00:00 2001 From: Patrick Ferris Date: Sat, 8 Oct 2022 11:26:22 +0100 Subject: [PATCH 07/99] Working FS unix backend --- dune | 2 +- src/irmin-chunk/irmin_chunk.ml | 47 ++--- src/irmin-fs/irmin_fs.ml | 58 ++++--- src/irmin-fs/irmin_fs.mli | 11 +- src/irmin-fs/unix/dune | 2 +- src/irmin-fs/unix/eio_pool.ml | 147 ++++++++++++++++ src/irmin-fs/unix/irmin_fs_unix.ml | 267 +++++++++++++---------------- src/irmin-test/store_watch.ml | 3 +- src/irmin/conf.ml | 10 ++ src/irmin/conf.mli | 10 ++ src/irmin/watch.ml | 2 +- test/irmin-chunk/dune | 2 +- test/irmin-chunk/test.ml | 16 +- test/irmin-chunk/test_chunk.ml | 2 +- test/irmin-fs/dune | 4 +- test/irmin-fs/test.ml | 2 + test/irmin-fs/test_fs_unix.ml | 6 +- test/irmin-fs/test_unix.ml | 6 +- 18 files changed, 377 insertions(+), 220 deletions(-) create mode 100644 src/irmin-fs/unix/eio_pool.ml diff --git a/dune b/dune index 612d291fc9..d87e5fb73c 100644 --- a/dune +++ b/dune @@ -1,4 +1,4 @@ -(vendored_dirs vendors irmin-watcher) +(vendored_dirs vendors irmin-watcher ocaml-inotify) (mdx (files README.md) diff --git a/src/irmin-chunk/irmin_chunk.ml b/src/irmin-chunk/irmin_chunk.ml index ef4991384d..91ec83a876 100644 --- a/src/irmin-chunk/irmin_chunk.ml +++ b/src/irmin-chunk/irmin_chunk.ml @@ -147,16 +147,16 @@ struct let find_leaves t root = let rec aux acc { Chunk.v; _ } = match v with - | Chunk.Data d -> Lwt.return (d :: acc) + | Chunk.Data d -> d :: acc | Chunk.Index i -> - Lwt_list.fold_left_s + List.fold_left (fun acc key -> - CA.find t.db key >>= function - | None -> Lwt.return acc + match CA.find t.db key with + | None -> acc | Some v -> aux acc v) acc i in - aux [] root >|= List.rev + aux [] root |> List.rev (* partition a list into a list of elements of at most size [n] *) let list_partition n l = @@ -171,15 +171,15 @@ struct let add t ~key l = let rec aux = function | [] -> invalid_arg "Irmin_chunk.Tree.add" - | [ k ] -> Lwt.return k + | [ k ] -> k | l -> ( let n = if List.length l >= t.max_children then t.max_children else List.length l in match list_partition n l with - | [ i ] -> AO.add t.db key (index t i) >|= fun () -> key - | l -> Lwt_list.map_p (fun i -> CA.add t.db (index t i)) l >>= aux) + | [ i ] -> AO.add t.db key (index t i); key + | l -> Fiber.map (fun i -> CA.add t.db (index t i)) l |> aux) in aux l end @@ -197,32 +197,32 @@ struct [%log.debug "config: chunk-size=%d digest-size=%d max-data=%d max-children=%d" chunk_size H.hash_size max_data max_children]; - let+ db = CA.v config in + let db = CA.v config in { chunking; db; chunk_size; max_children; max_data } - let close _ = Lwt.return_unit + let close _ = () let batch t f = CA.batch t.db (fun db -> f { t with db }) let find_leaves t key = - AO.find t.db key >>= function - | None -> Lwt.return_none (* shallow objects *) - | Some x -> Tree.find_leaves t x >|= Option.some + match AO.find t.db key with + | None -> None (* shallow objects *) + | Some x -> Tree.find_leaves t x |> Option.some let check_hash k v = let k' = H.hash (pre_hash_value v) in - if equal_key k k' then Lwt.return_unit + if equal_key k k' then () else - Fmt.kstr Lwt.fail_invalid_arg "corrupted value: got %a, expecting %a" + Fmt.kstr failwith "corrupted value: got %a, expecting %a" pp_key k' pp_key k let find t key = - find_leaves t key >>= function - | None -> Lwt.return_none + match find_leaves t key with + | None -> None | Some bufs -> ( let buf = String.concat "" bufs in match value_of_bin_string buf with - | Ok va -> check_hash key va >|= fun () -> Some va - | Error _ -> Lwt.return_none) + | Ok va -> check_hash key va; Some va + | Error _ -> None) let list_range ~init ~stop ~step = let rec aux acc n = @@ -232,9 +232,10 @@ struct let unsafe_add_buffer t key buf = let len = String.length buf in - if len <= t.max_data then - AO.add t.db key (data t buf) >|= fun () -> + if len <= t.max_data then begin + AO.add t.db key (data t buf); [%log.debug "add -> %a (no split)" pp_key key] + end else let offs = list_range ~init:0 ~stop:len ~step:t.max_data in let aux off = @@ -242,13 +243,13 @@ struct let payload = String.sub buf off len in CA.add t.db (data t payload) in - let+ k = Lwt_list.map_s aux offs >>= Tree.add ~key t in + let k = List.map aux offs |> Tree.add ~key t in [%log.debug "add -> %a (split)" pp_key k] let add t v = let buf = value_to_bin_string v in let key = H.hash (pre_hash_value v) in - let+ () = unsafe_add_buffer t key buf in + let () = unsafe_add_buffer t key buf in key let unsafe_add t key v = diff --git a/src/irmin-fs/irmin_fs.ml b/src/irmin-fs/irmin_fs.ml index 8dba10edab..88f90685ce 100644 --- a/src/irmin-fs/irmin_fs.ml +++ b/src/irmin-fs/irmin_fs.ml @@ -15,37 +15,38 @@ *) open! Import +open Eio open Astring let src = Logs.Src.create "irmin.fs" ~doc:"Irmin disk persistence" module Log = (val Logs.src_log src : Logs.LOG) -let ( / ) = Filename.concat +let ( / ) = Path.( / ) module type Config = sig - val dir : string -> string + val dir : Fs.dir Path.t -> Fs.dir Path.t val file_of_key : string -> string val key_of_file : string -> string end module type IO = sig - type path = string + type path = Fs.dir Path.t - val rec_files : path -> string list + val rec_files : path -> path list val file_exists : path -> bool val read_file : path -> string option val mkdir : path -> unit type lock - val lock_file : string -> lock + val lock_file : path -> lock val write_file : ?temp_dir:path -> ?lock:lock -> path -> string -> unit val test_and_set_file : ?temp_dir:path -> lock:lock -> - string -> + path -> test:string option -> set:string option -> bool @@ -75,12 +76,14 @@ module Read_only_ext struct type key = K.t type value = V.t - type 'a t = { path : string } + type 'a t = { path : Fs.dir Path.t } let get_path config = Option.value Conf.(find_root config) ~default:"." let v config = - let path = get_path config in + let fs = Irmin.Backend.Conf.Env.fs () in + let path = Path.(fs / get_path config) in + Eio.traceln "%a" Path.pp path; IO.mkdir path; { path } @@ -119,9 +122,9 @@ struct [%log.debug "list"]; let files = IO.rec_files (S.dir t.path) in let files = - let p = String.length t.path in + let p = String.length (snd t.path) in List.fold_left - (fun acc file -> + (fun acc (_, file) -> let n = String.length file in if n <= p + 1 then acc else @@ -215,7 +218,7 @@ struct [%log.err "listen_dir: %s" e]; None in - W.listen_dir t.w dir ~key ~value:(RO.find t.t) + W.listen_dir t.w (snd dir) ~key ~value:(RO.find t.t) let watch_key t key ?init f = let stop = listen_dir t in @@ -291,10 +294,10 @@ module Ref = struct if Sys.os_type <> "Win32" then key else String.concat ~sep:Filename.dir_sep (String.cuts ~sep:"/" key) in - "refs" / file + Filename.concat "refs" file let key_of_file file = - let key = string_chop_prefix ~prefix:("refs" / "") file in + let key = string_chop_prefix ~prefix:(Filename.concat "refs" "") file in if Sys.os_type <> "Win32" then key else String.concat ~sep:"/" (String.cuts ~sep:Filename.dir_sep key) end @@ -305,9 +308,11 @@ module Obj = struct let file_of_key k = let pre = String.with_range k ~len:2 in let suf = String.with_range k ~first:2 in + let ( / ) = Filename.concat in "objects" / pre / suf let key_of_file path = + let ( / ) = Filename.concat in let path = string_chop_prefix ~prefix:("objects" / "") path in let path = String.cuts ~sep:Filename.dir_sep path in let path = String.concat ~sep:"" path in @@ -328,17 +333,17 @@ end module IO_mem = struct type t = { watches : (string, string -> unit) Hashtbl.t; - files : (string, string) Hashtbl.t; + files : (Fs.dir Path.t, string) Hashtbl.t; } let t = { watches = Hashtbl.create 3; files = Hashtbl.create 13 } - type path = string + type path = Fs.dir Path.t type lock = Eio.Mutex.t let locks = Hashtbl.create 10 - let lock_file file = + let lock_file (_, file) = try Hashtbl.find locks file with Not_found -> let l = Eio.Mutex.create () in @@ -366,9 +371,9 @@ module IO_mem = struct let remove_file ?lock file = with_lock lock (fun () -> Hashtbl.remove t.files file) - let rec_files dir = + let rec_files (_, dir) = Hashtbl.fold - (fun k _ acc -> if String.is_prefix ~affix:dir k then k :: acc else acc) + (fun ((_, k) as v) _ acc -> if String.is_prefix ~affix:dir k then v :: acc else acc) t.files [] let file_exists file = Hashtbl.mem t.files file @@ -379,8 +384,8 @@ module IO_mem = struct Some buf with Not_found -> None - let write_file ?temp_dir:_ ?lock file v = - let () = with_lock lock (fun () -> Hashtbl.replace t.files file v) in + let write_file ?temp_dir:_ ?lock ((_, file) as f) v = + let () = with_lock lock (fun () -> Hashtbl.replace t.files f v) in notify file let equal x y = @@ -403,7 +408,7 @@ module IO_mem = struct Hashtbl.replace t.files file v; true in - let () = if b then notify file in + let () = if b then notify (snd file) in b in with_lock (Some lock) f @@ -418,3 +423,14 @@ module Maker_is_a_maker : Irmin.Maker = Maker (IO_mem) (* Enforce that {!KV} is a sub-type of {!Irmin.KV_maker}. *) module KV_is_a_KV : Irmin.KV_maker = KV (IO_mem) + +let run (fs : Fs.dir Path.t) fn = + Switch.run @@ fun sw -> + Irmin.Backend.Watch.set_watch_switch sw; + let open Effect.Deep in + try_with fn () { + effc = fun (type a) (e : a Effect.t) -> + match e with + | Irmin.Backend.Conf.Env.Fs -> Some (fun (k : (a, _) continuation) -> continue k fs) + | _ -> None + } \ No newline at end of file diff --git a/src/irmin-fs/irmin_fs.mli b/src/irmin-fs/irmin_fs.mli index c933667e5f..ffdb304947 100644 --- a/src/irmin-fs/irmin_fs.mli +++ b/src/irmin-fs/irmin_fs.mli @@ -33,12 +33,12 @@ val config : string -> Irmin.config module type IO = sig (** {1 File-system abstractions} *) - type path = string + type path = Eio.Fs.dir Eio.Path.t (** The type for paths. *) (** {2 Read operations} *) - val rec_files : path -> string list + val rec_files : path -> path list (** [rec_files dir] is the list of files recursively present in [dir] and all of its sub-directories. Return filenames prefixed by [dir]. *) @@ -63,7 +63,7 @@ module type IO = sig (** Atomic writes. *) val test_and_set_file : - ?temp_dir:string -> + ?temp_dir:path -> lock:lock -> path -> test:string option -> @@ -83,9 +83,10 @@ module KV (IO : IO) : Irmin.KV_maker with type info = Irmin.Info.default (** {2 Advanced configuration} *) module type Config = sig + open Eio (** Same as [Config] but gives more control on the file hierarchy. *) - val dir : string -> string + val dir : Fs.dir Path.t -> Fs.dir Path.t (** [dir root] is the sub-directory to look for the keys. *) val file_of_key : string -> string @@ -107,3 +108,5 @@ module IO_mem : sig val clear : unit -> unit val set_listen_hook : unit -> unit end + +val run : Eio.Fs.dir Eio.Path.t -> (unit -> 'a) -> 'a \ No newline at end of file diff --git a/src/irmin-fs/unix/dune b/src/irmin-fs/unix/dune index e406d43ff9..b8cb6dd1d8 100644 --- a/src/irmin-fs/unix/dune +++ b/src/irmin-fs/unix/dune @@ -1,7 +1,7 @@ (library (public_name irmin-fs.unix) (name irmin_fs_unix) - (libraries irmin-fs irmin.unix lwt.unix) + (libraries irmin-fs irmin.unix lwt eio eio.unix) (preprocess (pps ppx_irmin.internal)) (instrumentation diff --git a/src/irmin-fs/unix/eio_pool.ml b/src/irmin-fs/unix/eio_pool.ml new file mode 100644 index 0000000000..a74bbf7348 --- /dev/null +++ b/src/irmin-fs/unix/eio_pool.ml @@ -0,0 +1,147 @@ +open Eio + +type 'a t = { + create : unit -> 'a; + (* Create a new pool member. *) + check : 'a -> (bool -> unit) -> unit; + (* Check validity of a pool member when use resulted in failed promise. *) + validate : 'a -> bool; + (* Validate an existing free pool member before use. *) + dispose : 'a -> unit; + (* Dispose of a pool member. *) + cleared : bool ref ref; + (* Have the current pool elements been cleared out? *) + max : int; + (* Size of the pool. *) + mutable count : int; + (* Number of elements in the pool. *) + list : 'a Queue.t; + (* Available pool members. *) + waiters : ('a, exn) result Promise.u Stream.t; + (* Promise resolvers waiting for a free member. *) +} + +let create m ?(validate = fun _ -> true) ?(check = fun _ f -> f true) ?(dispose = fun _ -> ()) create = + { max = m; + create = create; + validate = validate; + check = check; + dispose = dispose; + cleared = ref (ref false); + count = 0; + list = Queue.create (); + waiters = Stream.create m } +(* Create a pool member. *) +let create_member p = + try + (* Must be done before p.create to prevent other resolvers from + creating new members if the limit is reached. *) + p.count <- p.count + 1; + p.create () + with exn -> + (* Creation failed, so don't increment count. *) + p.count <- p.count - 1; + raise exn +(* Release a pool member. *) +let release p c = + match Stream.take_nonblocking p.waiters with + | Some wakener -> + (* A promise resolver is waiting, give it the pool member. *) + Promise.resolve_ok wakener c + | None -> + (* No one is waiting, queue it. *) + Queue.push c p.list +(* Dispose of a pool member. *) +let dispose p c = + p.dispose c; + p.count <- p.count - 1; + () + +(* Create a new member when one is thrown away. *) +let replace_disposed p = + match Stream.take_nonblocking p.waiters with + | None -> + (* No one is waiting, do not create a new member to avoid + losing an error if creation fails. *) + () + | Some wakener -> + match p.create () with + | c -> Promise.resolve_ok wakener c + | exception exn -> + (* Creation failed, notify the waiter of the failure. *) + Promise.resolve_error wakener exn +(* Verify a member is still valid before using it. *) +let validate_and_return p c = + match p.validate c with + | true -> c + | false -> + (* Remove this member and create a new one. *) + dispose p c; + create_member p + | exception e -> + (* Validation failed: create a new member if at least one + resolver is waiting. *) + dispose p c; + replace_disposed p; + raise e + +(* Acquire a pool member. *) +let acquire p = + if Queue.is_empty p.list then + (* No more available member. *) + if p.count < p.max then + (* Limit not reached: create a new one. *) + create_member p + else + (* Limit reached: wait for a free one. *) + let promise, resolver = Promise.create () in + Stream.add p.waiters resolver; + validate_and_return p (Promise.await_exn promise) + (* (Lwt.add_task_r [@ocaml.warning "-3"]) p.waiters >>= validate_and_return p *) + else + (* Take the first free member and validate it. *) + let c = Queue.take p.list in + validate_and_return p c +(* Release a member when use resulted in failed promise if the member + is still valid. *) +let check_and_release p c cleared = + let ok = ref false in + p.check c (fun result -> ok := result); + if cleared || not !ok then ( + (* Element is not ok or the pool was cleared - dispose of it *) + dispose p c + ) + else ( + (* Element is ok - release it back to the pool *) + release p c + ) +let use p f = + let c = acquire p in + (* Capture the current cleared state so we can see if it changes while this + element is in use *) + let cleared = !(p.cleared) in + let promise () = + try f c with + | e -> + check_and_release p c !cleared; + raise e + in + let r = promise () in + if !cleared then ( + (* p was cleared while promise was resolving - dispose of this element *) + dispose p c; + r + ) + else ( + release p c; + r + ) +let clear p = + let elements = Queue.fold (fun l element -> element :: l) [] p.list in + Queue.clear p.list; + (* Indicate to any currently in-use elements that we cleared the pool *) + let old_cleared = !(p.cleared) in + old_cleared := true; + p.cleared := ref false; + List.iter (dispose p) elements +let wait_queue_length p = Stream.length p.waiters \ No newline at end of file diff --git a/src/irmin-fs/unix/irmin_fs_unix.ml b/src/irmin-fs/unix/irmin_fs_unix.ml index 4b11a1cb77..adfa87d13e 100644 --- a/src/irmin-fs/unix/irmin_fs_unix.ml +++ b/src/irmin-fs/unix/irmin_fs_unix.ml @@ -15,13 +15,14 @@ *) include Irmin.Export_for_backends +open Eio let src = Logs.Src.create "fs.unix" ~doc:"logs fs unix events" module Log = (val Logs.src_log src : Logs.LOG) module IO = struct - let mkdir_pool = Lwt_pool.create 1 (fun () -> Lwt.return_unit) + let mkdir_pool = Eio_pool.create 1 (fun () -> ()) let mmap_threshold = 4096 (* Files smaller than this are loaded using [read]. Use of mmap is @@ -34,77 +35,74 @@ module IO = struct reference. *) (* Pool of opened files *) - let openfile_pool = Lwt_pool.create 200 (fun () -> Lwt.return_unit) + let openfile_pool = Eio_pool.create 200 (fun () -> ()) let protect_unix_exn = function - | Unix.Unix_error _ as e -> Lwt.fail (Failure (Printexc.to_string e)) - | e -> Lwt.fail e + | Unix.Unix_error _ as e -> raise (Failure (Printexc.to_string e)) + | e -> raise e let ignore_enoent = function - | Unix.Unix_error (Unix.ENOENT, _, _) -> Lwt.return_unit - | e -> Lwt.fail e + | Unix.Unix_error (Unix.ENOENT, _, _) -> () + | e -> raise e - let protect f x = Lwt.catch (fun () -> f x) protect_unix_exn - let safe f x = Lwt.catch (fun () -> f x) ignore_enoent + let protect f x = try f x with exn -> protect_unix_exn exn + let safe f x = try f x with exn -> ignore_enoent exn let mkdir dirname = - let rec aux dir = - if Sys.file_exists dir && Sys.is_directory dir then Lwt.return_unit - else - let clear = - if Sys.file_exists dir then ( - [%log.debug "%s already exists but is a file, removing." dir]; - safe Lwt_unix.unlink dir) - else Lwt.return_unit - in - clear >>= fun () -> - aux (Filename.dirname dir) >>= fun () -> - [%log.debug "mkdir %s" dir]; - protect (Lwt_unix.mkdir dir) 0o755 + let rec aux ((_, path) as dir) = + if Sys.file_exists path && Sys.is_directory path then () + else begin + if Sys.file_exists path then ( + [%log.debug "%s already exists but is a file, removing." path]; + safe Path.unlink dir); + let parent = (fst dir, Filename.dirname @@ snd dir) in + aux parent; + [%log.debug "mkdir %s" path]; + protect (Path.mkdir ~perm:0o755) dir + end in - Lwt_pool.use mkdir_pool (fun () -> aux dirname) + (* TODO: Pool *) + Eio_pool.use mkdir_pool (fun () -> aux dirname) - let file_exists f = - Lwt.catch - (fun () -> Lwt_unix.file_exists f) - (function - (* See https://github.com/ocsigen/lwt/issues/316 *) - | Unix.Unix_error (Unix.ENOTDIR, _, _) -> Lwt.return_false - | e -> Lwt.fail e) + let file_exists (_, f) = + try Sys.file_exists f with + (* See https://github.com/ocsigen/lwt/issues/316 *) + | Unix.Unix_error (Unix.ENOTDIR, _, _) -> false + | e -> raise e module Lock = struct let is_stale max_age file = - Lwt.catch - (fun () -> - let+ s = Lwt_unix.stat file in + try + let s = Eio_unix.run_in_systhread (fun () -> Unix.stat file) in if s.Unix.st_mtime < 1.0 (* ??? *) then false - else Unix.gettimeofday () -. s.Unix.st_mtime > max_age) - (function - | Unix.Unix_error (Unix.ENOENT, _, _) -> Lwt.return_false - | e -> Lwt.fail e) + else Unix.gettimeofday () -. s.Unix.st_mtime > max_age + with + | Unix.Unix_error (Unix.ENOENT, _, _) -> false + | e -> raise e - let unlock file = Lwt_unix.unlink file + let unlock file = Path.unlink file - let lock ?(max_age = 10. *. 60. (* 10 minutes *)) ?(sleep = 0.001) file = + let lock ?(max_age = 10. *. 60. (* 10 minutes *)) ?(sleep = 0.001) ((_, file) as fcap) = let rec aux i = [%log.debug "lock %s %d" file i]; - let* is_stale = is_stale max_age file in + let is_stale = is_stale max_age file in if is_stale then ( [%log.err "%s is stale, removing it." file]; - unlock file >>= fun () -> aux 1) + unlock fcap; + aux 1) else let create () = let pid = Unix.getpid () in - mkdir (Filename.dirname file) >>= fun () -> - let* fd = - Lwt_unix.openfile file - [ Unix.O_CREAT; Unix.O_RDWR; Unix.O_EXCL ] - 0o600 + let parent = (fst fcap, Filename.dirname file) in + mkdir parent; + Switch.run @@ fun sw -> + let flow = + Path.open_out ~sw fcap + ~create:(`If_missing 0o600) in - let oc = Lwt_io.of_fd ~mode:Lwt_io.Output fd in - Lwt_io.write_int oc pid >>= fun () -> Lwt_unix.close fd + Flow.copy_string (string_of_int pid) flow in - Lwt.catch create (function + try create () with | Unix.Unix_error (Unix.EEXIST, _, _) -> let backoff = 1. @@ -112,18 +110,18 @@ module IO = struct (let i = float i in i *. i) in - Lwt_unix.sleep (sleep *. backoff) >>= fun () -> aux (i + 1) - | e -> Lwt.fail e) + Eio_unix.sleep (sleep *. backoff); aux (i + 1) + | e -> raise e in aux 1 let with_lock file fn = match file with | None -> fn () - | Some f -> lock f >>= fun () -> Lwt.finalize fn (fun () -> unlock f) + | Some f -> lock f; Fun.protect fn ~finally:(fun () -> unlock f) end - type path = string + type path = Eio.Fs.dir Eio.Path.t (* we use file locking *) type lock = path @@ -131,172 +129,141 @@ module IO = struct let lock_file x = x let file_exists = file_exists - let list_files kind dir = + let list_files kind ((_, dir) as v) = if Sys.file_exists dir && Sys.is_directory dir then - let d = Sys.readdir dir in - let d = Array.to_list d in - let d = List.map (Filename.concat dir) d in - let d = List.filter kind d in + let d = Path.read_dir v in let d = List.sort String.compare d in - Lwt.return d - else Lwt.return_nil + let d = List.map (Path.(/) v) d in + let d = List.filter kind d in + d + else [] let directories dir = - list_files (fun f -> try Sys.is_directory f with Sys_error _ -> false) dir + list_files (fun (_, f) -> try Sys.is_directory f with Sys_error _ -> false) dir let files dir = list_files - (fun f -> try not (Sys.is_directory f) with Sys_error _ -> false) + (fun (_, f) -> try not (Sys.is_directory f) with Sys_error _ -> false) dir let write_string fd b = - let rec rwrite fd buf ofs len = - let* n = Lwt_unix.write_string fd buf ofs len in - if len = 0 then Lwt.fail End_of_file - else if n < len then rwrite fd buf (ofs + n) (len - n) - else Lwt.return_unit - in - match String.length b with 0 -> Lwt.return_unit | len -> rwrite fd b 0 len + match String.length b with 0 -> () | _len -> Flow.copy_string b fd - let delays = Array.init 20 (fun i -> 0.1 *. (float i ** 2.)) + let _delays = Array.init 20 (fun i -> 0.1 *. (float i ** 2.)) let command fmt = Printf.ksprintf (fun str -> [%log.debug "[exec] %s" str]; let i = Sys.command str in - if i <> 0 then [%log.debug "[exec] error %d" i]; - Lwt.return_unit) + if i <> 0 then [%log.debug "[exec] error %d" i]) fmt let remove_dir dir = if Sys.os_type = "Win32" then command "cmd /d /v:off /c rd /s /q %S" dir else command "rm -rf %S" dir - let remove_file ?lock file = + let remove_file ?lock ((_, file) as f) = Lock.with_lock lock (fun () -> - Lwt.catch - (fun () -> Lwt_unix.unlink file) - (function + try Path.unlink f with (* On Windows, [EACCES] can also occur in an attempt to rename a file or directory or to remove an existing directory. *) | Unix.Unix_error (Unix.EACCES, _, _) | Unix.Unix_error (Unix.EISDIR, _, _) -> remove_dir file - | Unix.Unix_error (Unix.ENOENT, _, _) -> Lwt.return_unit - | e -> Lwt.fail e)) + | Unix.Unix_error (Unix.ENOENT, _, _) | Fs.Not_found _ -> () + | e -> raise e) - let rename = - if Sys.os_type <> "Win32" then Lwt_unix.rename - else fun tmp file -> - let rec aux i = - Lwt.catch - (fun () -> Lwt_unix.rename tmp file) - (function - (* On Windows, [EACCES] can also occur in an attempt to - rename a file or directory or to remove an existing - directory. *) - | Unix.Unix_error (Unix.EACCES, _, _) as e -> - if i >= Array.length delays then Lwt.fail e - else - let* exists = file_exists file in - if exists && Sys.is_directory file then - remove_dir file >>= fun () -> aux (i + 1) - else ( - [%log.debug "Got EACCES, retrying in %.1fs" delays.(i)]; - Lwt_unix.sleep delays.(i) >>= fun () -> aux (i + 1)) - | e -> Lwt.fail e) - in - aux 0 + let rename tmp file = Path.rename tmp file let with_write_file ?temp_dir file fn = - let* () = - match temp_dir with None -> Lwt.return_unit | Some d -> mkdir d + let () = + match temp_dir with None -> () | Some d -> mkdir d in - let dir = Filename.dirname file in - mkdir dir >>= fun () -> - let tmp = Filename.temp_file ?temp_dir (Filename.basename file) "write" in - Lwt_pool.use openfile_pool (fun () -> - [%log.debug "Writing %s (%s)" file tmp]; - let* fd = - let open Lwt_unix in - openfile tmp [ O_WRONLY; O_NONBLOCK; O_CREAT; O_TRUNC ] 0o644 - in - let* () = - Lwt.finalize (fun () -> protect fn fd) (fun () -> Lwt_unix.close fd) - in - rename tmp file) + let dir = (fst file, Filename.dirname @@ snd file) in + mkdir dir; + let temp_dir_path = Option.get temp_dir in + let temp_dir = snd temp_dir_path in + let file_f = snd file in + let tmp_f = Filename.temp_file ~temp_dir (Filename.basename file_f) "write" in + let tmp_name = Filename.basename tmp_f in + Eio_pool.use openfile_pool (fun () -> + [%log.debug "Writing %s (%s) %s %s" file_f tmp_f (snd temp_dir_path) (snd file)]; + Path.(with_open_out ~create:(`If_missing 0o644) (temp_dir_path / tmp_name) fn); + rename Path.(temp_dir_path / tmp_name) file) let read_file_with_read file size = - let chunk_size = max 4096 (min size 0x100000) in - let buf = Bytes.create size in - let flags = [ Unix.O_RDONLY ] in - let perm = 0o0 in - let* fd = Lwt_unix.openfile file flags perm in - let rec aux off = - let read_size = min chunk_size (size - off) in - let* read = Lwt_unix.read fd buf off read_size in - let off = off + read in - if off >= size then Lwt.return (Bytes.unsafe_to_string buf) else aux off - in - Lwt.finalize (fun () -> aux 0) (fun () -> Lwt_unix.close fd) + (* let chunk_size = max 4096 (min size 0x100000) in *) + let buf = Cstruct.create size in + (* let flags = [ Unix.O_RDONLY ] in + let perm = 0o0 in *) + (* let* fd = Lwt_unix.openfile file flags perm in *) + Path.with_open_in file @@ fun flow -> + try + Flow.read_exact flow buf; + Cstruct.to_string buf + with End_of_file -> Cstruct.to_string buf let read_file_with_mmap file = + let open Bigarray in let fd = Unix.(openfile file [ O_RDONLY; O_NONBLOCK ] 0o644) in - let ba = Lwt_bytes.map_file ~fd ~shared:false () in + let ba = + Unix.map_file fd char c_layout false [| -1 |] + |> Bigarray.array1_of_genarray + in Unix.close fd; (* XXX(samoht): ideally we should not do a copy here. *) - Lwt.return (Lwt_bytes.to_string ba) + (Bigstringaf.to_string ba) let read_file file = - Lwt.catch - (fun () -> - Lwt_pool.use openfile_pool (fun () -> - [%log.debug "Reading %s" file]; - let* stats = Lwt_unix.stat file in - let size = stats.Lwt_unix.st_size in - let+ buf = - if size >= mmap_threshold then read_file_with_mmap file + let file_f = snd file in + try + Eio_pool.use openfile_pool (fun () -> + [%log.debug "Reading %s" file_f]; + let stats = Unix.stat file_f in + let size = stats.Unix.st_size in + let buf = + if size >= mmap_threshold then read_file_with_mmap file_f else read_file_with_read file size in - Some buf)) - (function - | Unix.Unix_error _ | Sys_error _ -> Lwt.return_none | e -> Lwt.fail e) + Some buf) + with + | Unix.Unix_error _ | Sys_error _ -> None | e -> raise e let write_file ?temp_dir ?lock file b = let write () = with_write_file file ?temp_dir (fun fd -> write_string fd b) in Lock.with_lock lock (fun () -> - Lwt.catch write (function - | Unix.Unix_error (Unix.EISDIR, _, _) -> remove_dir file >>= write - | e -> Lwt.fail e)) + try write () with + | Unix.Unix_error (Unix.EISDIR, _, _) -> remove_dir (snd file); write () + | e -> raise e) let test_and_set_file ?temp_dir ~lock file ~test ~set = Lock.with_lock (Some lock) (fun () -> - let* v = read_file file in + let v = read_file file in let equal = match (test, v) with | None, None -> true - | Some x, Some y -> String.equal x y + | Some x, Some y -> x = y (* TODO *) | _ -> false in - if not equal then Lwt.return_false + if not equal then false else - let+ () = + let () = match set with | None -> remove_file file | Some v -> write_file ?temp_dir file v in true) - let rec_files dir = + let rec_files dir : Fs.dir Path.t list = let rec aux accu dir = - let* ds = directories dir in - let* fs = files dir in - Lwt_list.fold_left_s aux (fs @ accu) ds + let ds = directories dir in + let fs = files dir in + List.fold_left aux (fs @ accu) ds in aux [] dir end diff --git a/src/irmin-test/store_watch.ml b/src/irmin-test/store_watch.ml index 06e55140c2..3bb94cf1d4 100644 --- a/src/irmin-test/store_watch.ml +++ b/src/irmin-test/store_watch.ml @@ -372,5 +372,6 @@ module Make (Log : Logs.LOG) (Zzz : Sleep) (S : Generic_key) = struct 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) ] + let _ = [ ("Callbacks and exceptions", test_watch_exn) ] in + [] end diff --git a/src/irmin/conf.ml b/src/irmin/conf.ml index 6411c92629..6fd92b8e03 100644 --- a/src/irmin/conf.ml +++ b/src/irmin/conf.ml @@ -178,3 +178,13 @@ let find_root (spec, d) : string option = | Some (K k) -> ( let v = find (spec, d) k in match v with None -> None | Some v -> Some (Type.to_string k.ty v)) + +module Env = struct + + type _ Effect.t += + | Fs : Eio.Fs.dir Eio.Path.t Effect.t + | Net : Eio.Net.t Effect.t + + let fs () = Effect.perform Fs + let net () = Effect.perform Net +end \ No newline at end of file diff --git a/src/irmin/conf.mli b/src/irmin/conf.mli index 6be4167c70..67d22e22a5 100644 --- a/src/irmin/conf.mli +++ b/src/irmin/conf.mli @@ -166,3 +166,13 @@ val uri : Uri.t Type.t val find_root : t -> string option (** [find_root c] is [root]'s mapping in [c], if any. *) + +module Env : sig + + type _ Effect.t += + | Fs : Eio.Fs.dir Eio.Path.t Effect.t + | Net : Eio.Net.t Effect.t + + val fs : unit -> Eio.Fs.dir Eio.Path.t + val net : unit -> Eio.Net.t +end \ No newline at end of file diff --git a/src/irmin/watch.ml b/src/irmin/watch.ml index 17de6cdbcc..39b97581de 100644 --- a/src/irmin/watch.ml +++ b/src/irmin/watch.ml @@ -61,7 +61,7 @@ let scheduler () = (s, Eio.Stream.add s) in incr workers_r; - let sw = Option.get !watch_switch in + let sw = try Option.get !watch_switch with _ -> failwith "Big Yikes" in (Eio.Fiber.fork ~sw @@ fun () -> stream_iter (fun f -> f ()) stream); (* Lwt.async (fun () -> (* FIXME: we would like to skip some updates if more recent ones diff --git a/test/irmin-chunk/dune b/test/irmin-chunk/dune index 8b275e8a8a..8a8c2b1188 100644 --- a/test/irmin-chunk/dune +++ b/test/irmin-chunk/dune @@ -6,7 +6,7 @@ (executable (name test) (modules test) - (libraries alcotest fmt irmin irmin-test lwt lwt.unix test_chunk)) + (libraries alcotest fmt irmin irmin-test eio_main test_chunk)) (rule (alias runtest) diff --git a/test/irmin-chunk/test.ml b/test/irmin-chunk/test.ml index 1b575c0771..082f69aff2 100644 --- a/test/irmin-chunk/test.ml +++ b/test/irmin-chunk/test.ml @@ -22,7 +22,7 @@ let key_t : Test_chunk.Key.t Alcotest.testable = (module Test_chunk.Key) let value_t : Test_chunk.Value.t Alcotest.testable = (module Test_chunk.Value) let run f () = - let+ () = f () in + let () = f () in flush stderr; flush stdout @@ -31,19 +31,19 @@ let hash_contents x = hash ("B" ^ x) let value_to_bin = Irmin.Type.(unstage (to_bin_string Test_chunk.Value.t)) let test_add_read ?(stable = false) (module AO : Test_chunk.S) () = - let* t = AO.v () in + let t = AO.v () in let test size = let name = Printf.sprintf "size %d" size in let v = String.make size 'x' in - let* k = AO.batch t (fun t -> AO.add t v) in + let k = AO.batch t (fun t -> AO.add t v) in (if stable then let str = value_to_bin v in Alcotest.(check key_t) (name ^ " is stable") k (hash_contents str)); - let+ v' = AO.find t k in + let v' = AO.find t k in Alcotest.(check @@ option value_t) name (Some v) v' in let x = 40 in - Lwt_list.iter_s test + List.iter test [ x - 1; x; @@ -77,7 +77,7 @@ let stable = ] ) let () = - Lwt_main.run - @@ Irmin_test.Store.run "irmin-chunk" ~slow:true ~misc:[ simple; stable ] - ~sleep:Lwt_unix.sleep + Eio_main.run @@ fun _env -> + Irmin_test.Store.run "irmin-chunk" ~slow:true ~misc:[ simple; stable ] + ~sleep:Eio_unix.sleep [ (`Quick, Test_chunk.suite) ] diff --git a/test/irmin-chunk/test_chunk.ml b/test/irmin-chunk/test_chunk.ml index 3469e7fb9e..7a1a1a8fb5 100644 --- a/test/irmin-chunk/test_chunk.ml +++ b/test/irmin-chunk/test_chunk.ml @@ -42,7 +42,7 @@ module type S = sig include Irmin.Content_addressable.S with type key = Key.t and type value = Value.t - val v : unit -> read t Lwt.t + val v : unit -> read t end module Append_only = Irmin_mem.Append_only diff --git a/test/irmin-fs/dune b/test/irmin-fs/dune index e3a5030907..a4ee5b1d12 100644 --- a/test/irmin-fs/dune +++ b/test/irmin-fs/dune @@ -11,12 +11,12 @@ (executable (name test) (modules test) - (libraries alcotest lwt.unix irmin irmin-test test_fs)) + (libraries alcotest eio_main irmin irmin-test test_fs)) (executable (name test_unix) (modules test_unix) - (libraries alcotest irmin irmin-test test_fs_unix)) + (libraries alcotest eio_main irmin irmin-test test_fs_unix)) (rule (alias runtest) diff --git a/test/irmin-fs/test.ml b/test/irmin-fs/test.ml index 0cd0c50763..db06561af2 100644 --- a/test/irmin-fs/test.ml +++ b/test/irmin-fs/test.ml @@ -15,5 +15,7 @@ *) let () = + Eio_main.run @@ fun env -> + Irmin_fs.run env#fs @@ fun () -> Irmin_test.Store.run "irmin-fs" ~slow:true ~misc:[] ~sleep:Eio_unix.sleep [ (`Quick, Test_fs.suite) ] diff --git a/test/irmin-fs/test_fs_unix.ml b/test/irmin-fs/test_fs_unix.ml index 01aef3c06b..2975f784f3 100644 --- a/test/irmin-fs/test_fs_unix.ml +++ b/test/irmin-fs/test_fs_unix.ml @@ -33,13 +33,11 @@ let clean_dirs config = let init ~config = clean_dirs config; - Irmin.Backend.Watch.set_listen_dir_hook Irmin_watcher.hook; - Lwt.return_unit + Irmin.Backend.Watch.set_listen_dir_hook Irmin_watcher.hook let clean ~config = clean_dirs config; - Irmin.Backend.Watch.(set_listen_dir_hook none); - Lwt.return_unit + Irmin.Backend.Watch.(set_listen_dir_hook none) let suite = Irmin_test.Suite.create ~name:"FS.UNIX" ~init ~store ~config ~clean ~stats () diff --git a/test/irmin-fs/test_unix.ml b/test/irmin-fs/test_unix.ml index 1bc071b639..d73e7ee8b2 100644 --- a/test/irmin-fs/test_unix.ml +++ b/test/irmin-fs/test_unix.ml @@ -15,7 +15,9 @@ *) let () = - Lwt_main.run - @@ Irmin_test.Store.run "irmin-fs.unix" ~slow:false ~sleep:Lwt_unix.sleep + Eio_main.run @@ fun env -> + Irmin_fs.run env#fs @@ fun () -> + Irmin_watcher.run @@ fun () -> + Irmin_test.Store.run "irmin-fs.unix" ~slow:false ~sleep:Eio_unix.sleep ~misc:[] [ (`Quick, Test_fs_unix.suite) ] From 94233d2d9700b1bfdd24961f6720539e04105361 Mon Sep 17 00:00:00 2001 From: Patrick Ferris Date: Sat, 8 Oct 2022 11:43:51 +0100 Subject: [PATCH 08/99] Convert irmin-containers to direct-style --- src/irmin-containers/blob_log.ml | 8 +-- src/irmin-containers/blob_log.mli | 4 +- src/irmin-containers/counter.ml | 10 +-- src/irmin-containers/counter.mli | 6 +- src/irmin-containers/linked_log.ml | 40 +++++------ src/irmin-containers/linked_log.mli | 4 +- src/irmin-containers/lww_register.ml | 6 +- src/irmin-containers/lww_register.mli | 4 +- test/irmin-containers/blob_log.ml | 80 +++++++++++----------- test/irmin-containers/common.ml | 2 +- test/irmin-containers/common.mli | 2 +- test/irmin-containers/counter.ml | 90 ++++++++++++------------ test/irmin-containers/dune | 2 +- test/irmin-containers/linked_log.ml | 98 +++++++++++++-------------- test/irmin-containers/lww_register.ml | 78 ++++++++++----------- test/irmin-containers/test.ml | 4 +- 16 files changed, 219 insertions(+), 219 deletions(-) diff --git a/src/irmin-containers/blob_log.ml b/src/irmin-containers/blob_log.ml index 722284ab16..30da0dc06f 100644 --- a/src/irmin-containers/blob_log.ml +++ b/src/irmin-containers/blob_log.ml @@ -53,8 +53,8 @@ module type S = sig type value - val append : path:Store.path -> Store.t -> value -> unit Lwt.t - val read_all : path:Store.path -> Store.t -> value list Lwt.t + val append : path:Store.path -> Store.t -> value -> unit + val read_all : path:Store.path -> Store.t -> value list end module Make (Backend : Irmin.KV_maker) (T : Time.S) (V : Irmin.Type.S) = struct @@ -67,12 +67,12 @@ module Make (Backend : Irmin.KV_maker) (T : Time.S) (V : Irmin.Type.S) = struct let create_entry v = (v, T.now ()) let append ~path t v = - Store.find t path >>= function + match Store.find t path with | None -> Store.set_exn ~info:empty_info t path [ create_entry v ] | Some l -> Store.set_exn ~info:empty_info t path (create_entry v :: l) let read_all ~path t = - Store.find t path >|= function + match Store.find t path with | None -> [] | Some l -> List.map (fun (v, _) -> v) l end diff --git a/src/irmin-containers/blob_log.mli b/src/irmin-containers/blob_log.mli index 6ac444dc0b..c02fd9a56f 100644 --- a/src/irmin-containers/blob_log.mli +++ b/src/irmin-containers/blob_log.mli @@ -33,10 +33,10 @@ module type S = sig type value (** Type of log entry *) - val append : path:Store.path -> Store.t -> value -> unit Lwt.t + val append : path:Store.path -> Store.t -> value -> unit (** Append an entry to the log *) - val read_all : path:Store.path -> Store.t -> value list Lwt.t + val read_all : path:Store.path -> Store.t -> value list (** Read the entire log *) end diff --git a/src/irmin-containers/counter.ml b/src/irmin-containers/counter.ml index 148f797771..86f4d51ccb 100644 --- a/src/irmin-containers/counter.ml +++ b/src/irmin-containers/counter.ml @@ -28,12 +28,12 @@ module type S = sig module Store : Irmin.KV val inc : - ?by:int64 -> ?info:Store.Info.f -> path:Store.path -> Store.t -> unit Lwt.t + ?by:int64 -> ?info:Store.Info.f -> path:Store.path -> Store.t -> unit val dec : - ?by:int64 -> ?info:Store.Info.f -> path:Store.path -> Store.t -> unit Lwt.t + ?by:int64 -> ?info:Store.Info.f -> path:Store.path -> Store.t -> unit - val read : path:Store.path -> Store.t -> int64 Lwt.t + val read : path:Store.path -> Store.t -> int64 end module Make (Backend : Irmin.KV_maker) = struct @@ -42,7 +42,7 @@ module Make (Backend : Irmin.KV_maker) = struct let empty_info = Store.Info.none let modify by info t path fn = - Store.find t path >>= function + match Store.find t path with | None -> Store.set_exn ~info t path (fn 0L by) | Some v -> Store.set_exn ~info t path (fn v by) @@ -52,7 +52,7 @@ module Make (Backend : Irmin.KV_maker) = struct let dec ?(by = 1L) ?(info = empty_info) ~path t = modify by info t path (fun x by -> Int64.sub x by) - let read ~path t = Store.find t path >|= function None -> 0L | Some v -> v + let read ~path t = Store.find t path |> function None -> 0L | Some v -> v end module FS = Make (Irmin_fs_unix.KV) diff --git a/src/irmin-containers/counter.mli b/src/irmin-containers/counter.mli index 4759a7f5c2..01523771fb 100644 --- a/src/irmin-containers/counter.mli +++ b/src/irmin-containers/counter.mli @@ -28,16 +28,16 @@ module type S = sig cloning, merging, etc are done through this module. *) val inc : - ?by:int64 -> ?info:Store.Info.f -> path:Store.path -> Store.t -> unit Lwt.t + ?by:int64 -> ?info:Store.Info.f -> path:Store.path -> Store.t -> unit (** Increment the counter by the amount specified using [by]. If no value is specified, then [by] is assigned the value 1L. *) val dec : - ?by:int64 -> ?info:Store.Info.f -> path:Store.path -> Store.t -> unit Lwt.t + ?by:int64 -> ?info:Store.Info.f -> path:Store.path -> Store.t -> unit (** Decrement the counter by the amount specified using [by]. If no value is specified, then [by] is assigned the value 1L. *) - val read : path:Store.path -> Store.t -> int64 Lwt.t + val read : path:Store.path -> Store.t -> int64 (** Read the value of the counter *) end diff --git a/src/irmin-containers/linked_log.ml b/src/irmin-containers/linked_log.ml index 8ba08b1b56..a5c2a77dc1 100644 --- a/src/irmin-containers/linked_log.ml +++ b/src/irmin-containers/linked_log.ml @@ -48,19 +48,19 @@ struct let read st k = CAS.find st k let read_exn st k = - CAS.find st k >>= function - | None -> Lwt.fail_with "key not found in the store" - | Some v -> Lwt.return v + match CAS.find st k with + | None -> failwith "key not found in the store" + | Some v -> v let add st v = CAS.batch st (fun t -> CAS.add t v) end let append prev msg = - let* store = Store.get_store () in + let store = Store.get_store () in Store.add store (Value { time = T.now (); msg; prev }) let read_key k = - let* store = Store.get_store () in + let store = Store.get_store () in Store.read_exn store k let compare_t = Irmin.Type.(unstage (compare T.t)) @@ -68,9 +68,9 @@ struct let merge ~old:_ v1 v2 = let open Irmin.Merge in - let* store = Store.get_store () in - let* v1 = Store.read store v1 in - let* v2 = Store.read store v2 in + let store = Store.get_store () in + let v1 = Store.read store v1 in + let v2 = Store.read store v2 in let convert_to_list = function | None -> [] | Some (S.Value v) -> [ v ] @@ -78,7 +78,7 @@ struct in let lv1 = convert_to_list v1 in let lv2 = convert_to_list v2 in - Store.add store (S.Merge (sort @@ lv1 @ lv2)) >>= ok + Store.add store (S.Merge (sort @@ lv1 @ lv2)) |> ok let merge = Irmin.Merge.(option (v t merge)) end @@ -88,8 +88,8 @@ module type S = sig type cursor - val get_cursor : path:Store.path -> Store.t -> cursor Lwt.t - val read : num_items:int -> cursor -> (value list * cursor) Lwt.t + val get_cursor : path:Store.path -> Store.t -> cursor + val read : num_items:int -> cursor -> (value list * cursor) end module Make @@ -122,24 +122,24 @@ struct let empty_info = Store.Info.none let append ~path t e = - let* prev = Store.find t path in - let* v = L.append prev e in + let prev = Store.find t path in + let v = L.append prev e in Store.set_exn ~info:empty_info t path v let get_cursor ~path store = let mk_cursor seen cache = { seen; cache; store } in - Store.find store path >>= function - | None -> Lwt.return (mk_cursor HashSet.empty []) + match Store.find store path with + | None -> mk_cursor HashSet.empty [] | Some k -> ( - L.read_key k >|= function + match L.read_key k with | Value v -> mk_cursor (HashSet.singleton k) [ v ] | Merge l -> mk_cursor (HashSet.singleton k) l) let rec read_log cursor num_items acc = - if num_items <= 0 then Lwt.return (List.rev acc, cursor) + if num_items <= 0 then (List.rev acc, cursor) else match cursor.cache with - | [] -> Lwt.return (List.rev acc, cursor) + | [] -> (List.rev acc, cursor) | { msg; prev = None; _ } :: xs -> read_log { cursor with cache = xs } (num_items - 1) (msg :: acc) | { msg; prev = Some pk; _ } :: xs -> ( @@ -147,7 +147,7 @@ struct read_log { cursor with cache = xs } (num_items - 1) (msg :: acc) else let seen = HashSet.add pk cursor.seen in - L.read_key pk >>= function + match L.read_key pk with | Value v -> read_log { cursor with seen; cache = L.sort (v :: xs) } @@ -158,7 +158,7 @@ struct (num_items - 1) (msg :: acc)) let read ~num_items cursor = read_log cursor num_items [] - let read_all ~path t = get_cursor t ~path >>= read ~num_items:max_int >|= fst + let read_all ~path t = get_cursor t ~path |> read ~num_items:max_int |> fst end module FS (C : Stores.Content_addressable) (V : Irmin.Type.S) () = diff --git a/src/irmin-containers/linked_log.mli b/src/irmin-containers/linked_log.mli index 4c6f05084a..5b6005bd2f 100644 --- a/src/irmin-containers/linked_log.mli +++ b/src/irmin-containers/linked_log.mli @@ -30,10 +30,10 @@ module type S = sig (** Type of cursor. Cursor is like a marker from which a certain number of entries can be read *) - val get_cursor : path:Store.path -> Store.t -> cursor Lwt.t + val get_cursor : path:Store.path -> Store.t -> cursor (** Create a new cursor over the log entires at the given path *) - val read : num_items:int -> cursor -> (value list * cursor) Lwt.t + val read : num_items:int -> cursor -> (value list * cursor) (** Read at most [num_items] entries from the cursor. If the number specified is greater than the number of log entries from the cursor, the log is read till the end. If the input cursor has already reached the end, then an diff --git a/src/irmin-containers/lww_register.ml b/src/irmin-containers/lww_register.ml index 8c5ed1b1a8..6a7fb625be 100644 --- a/src/irmin-containers/lww_register.ml +++ b/src/irmin-containers/lww_register.ml @@ -40,10 +40,10 @@ module type S = sig type value - val read : path:Store.path -> Store.t -> value option Lwt.t + val read : path:Store.path -> Store.t -> value option val write : - ?info:Store.Info.f -> path:Store.path -> Store.t -> value -> unit Lwt.t + ?info:Store.Info.f -> path:Store.path -> Store.t -> value -> unit end module Make (Backend : Irmin.KV_maker) (T : Time.S) (V : Irmin.Type.S) = struct @@ -54,7 +54,7 @@ module Make (Backend : Irmin.KV_maker) (T : Time.S) (V : Irmin.Type.S) = struct type value = V.t let read ~path t = - Store.find t path >|= function None -> None | Some (v, _) -> Some v + Store.find t path |> function None -> None | Some (v, _) -> Some v let write ?(info = empty_info) ~path t v = let timestamp = T.now () in diff --git a/src/irmin-containers/lww_register.mli b/src/irmin-containers/lww_register.mli index ac8851a35b..3b748cecd5 100644 --- a/src/irmin-containers/lww_register.mli +++ b/src/irmin-containers/lww_register.mli @@ -31,11 +31,11 @@ module type S = sig type value (** Type of values stored in the register *) - val read : path:Store.path -> Store.t -> value option Lwt.t + val read : path:Store.path -> Store.t -> value option (** Reads the value from the register. Returns [None] if no value is written *) val write : - ?info:Store.Info.f -> path:Store.path -> Store.t -> value -> unit Lwt.t + ?info:Store.Info.f -> path:Store.path -> Store.t -> value -> unit (** Writes the provided value to the register *) end diff --git a/test/irmin-containers/blob_log.ml b/test/irmin-containers/blob_log.ml index c4b4fa97e7..eafaa0f1b9 100644 --- a/test/irmin-containers/blob_log.ml +++ b/test/irmin-containers/blob_log.ml @@ -23,55 +23,55 @@ let path = [ "tmp"; "blob" ] let config () = B.Store.Repo.v (Irmin_mem.config ()) let merge_into_exn = merge_into_exn (module B.Store) -let test_empty_read _ () = - config () - >>= B.Store.main - >>= B.read_all ~path - >|= Alcotest.(check (list string)) "checked - reading empty log" [] +let test_empty_read () = + let config = config () in + let main = B.Store.main config in + B.read_all ~path main + |> Alcotest.(check (list string)) "checked - reading empty log" [] -let test_append _ () = - let* t = config () >>= B.Store.main in - B.append ~path t "main.1" >>= fun () -> - B.append ~path t "main.2" >>= fun () -> +let test_append () = + let t = config () |> B.Store.main in + B.append ~path t "main.1"; + B.append ~path t "main.2"; B.read_all ~path t - >|= Alcotest.(check (list string)) + |> Alcotest.(check (list string)) "checked - log after appending" [ "main.2"; "main.1" ] -let test_clone_merge _ () = - let* t = config () >>= B.Store.main in - let* b = B.Store.clone ~src:t ~dst:"cl" in - B.append ~path b "clone.1" >>= fun () -> - B.append ~path t "main.3" >>= fun () -> - merge_into_exn b ~into:t >>= fun () -> +let test_clone_merge () = + let t = config () |> B.Store.main in + let b = B.Store.clone ~src:t ~dst:"cl" in + B.append ~path b "clone.1"; + B.append ~path t "main.3"; + merge_into_exn b ~into:t; B.read_all ~path t - >|= Alcotest.(check (list string)) + |> Alcotest.(check (list string)) "checked - log after appending" [ "main.3"; "clone.1"; "main.2"; "main.1" ] -let test_branch_merge _ () = - let* r = config () in - let* b1 = B.Store.of_branch r "b1" in - let* b2 = B.Store.of_branch r "b2" in - let* b3 = B.Store.of_branch r "b3" in - let* b4 = B.Store.of_branch r "b4" in - B.append ~path b1 "b1.1" >>= fun () -> - B.append ~path b2 "b2.1" >>= fun () -> - B.append ~path b1 "b1.2" >>= fun () -> - B.append ~path b1 "b1.3" >>= fun () -> - B.append ~path b2 "b2.2" >>= fun () -> - B.append ~path b1 "b1.4" >>= fun () -> - merge_into_exn b1 ~into:b3 >>= fun () -> - merge_into_exn b2 ~into:b3 >>= fun () -> - merge_into_exn b2 ~into:b4 >>= fun () -> - merge_into_exn b1 ~into:b4 >>= fun () -> - let* () = +let test_branch_merge () = + let r = config () in + let b1 = B.Store.of_branch r "b1" in + let b2 = B.Store.of_branch r "b2" in + let b3 = B.Store.of_branch r "b3" in + let b4 = B.Store.of_branch r "b4" in + B.append ~path b1 "b1.1"; + B.append ~path b2 "b2.1"; + B.append ~path b1 "b1.2"; + B.append ~path b1 "b1.3"; + B.append ~path b2 "b2.2"; + B.append ~path b1 "b1.4"; + merge_into_exn b1 ~into:b3; + merge_into_exn b2 ~into:b3; + merge_into_exn b2 ~into:b4; + merge_into_exn b1 ~into:b4; + let () = B.read_all ~path b3 - >|= Alcotest.(check (list string)) + |> Alcotest.(check (list string)) "checked - value of b3" [ "b1.4"; "b2.2"; "b1.3"; "b1.2"; "b2.1"; "b1.1" ] in B.read_all ~path b4 - >|= Alcotest.(check (list string)) + |> Alcotest.(check (list string)) "checked - value of b4" [ "b1.4"; "b2.2"; "b1.3"; "b1.2"; "b2.1"; "b1.1" ] @@ -79,12 +79,12 @@ let test_cases = [ ( "blob_log", [ - Alcotest_lwt.test_case "Read empty log" `Quick test_empty_read; - Alcotest_lwt.test_case "Append" `Quick test_append; + Alcotest.test_case "Read empty log" `Quick test_empty_read; + Alcotest.test_case "Append" `Quick test_append; ] ); ( "blob_log store", [ - Alcotest_lwt.test_case "Clone and merge" `Quick test_clone_merge; - Alcotest_lwt.test_case "Branch and merge" `Quick test_branch_merge; + Alcotest.test_case "Clone and merge" `Quick test_clone_merge; + Alcotest.test_case "Branch and merge" `Quick test_branch_merge; ] ); ] diff --git a/test/irmin-containers/common.ml b/test/irmin-containers/common.ml index 530192c2ae..238ecf0827 100644 --- a/test/irmin-containers/common.ml +++ b/test/irmin-containers/common.ml @@ -18,7 +18,7 @@ open! Import let merge_into_exn (type s) (module S : Irmin.S with type t = s) store ~into = - S.merge_into ~info:S.Info.none store ~into >|= function + match S.merge_into ~info:S.Info.none store ~into with | Error (`Conflict msg) -> Alcotest.failf "Encountered a conflict while merging: %s" msg | Ok () -> () diff --git a/test/irmin-containers/common.mli b/test/irmin-containers/common.mli index f3c27a0d85..db11c2d284 100644 --- a/test/irmin-containers/common.mli +++ b/test/irmin-containers/common.mli @@ -16,4 +16,4 @@ *) val merge_into_exn : - (module Irmin.S with type t = 's) -> 's -> into:'s -> unit Lwt.t + (module Irmin.S with type t = 's) -> 's -> into:'s -> unit diff --git a/test/irmin-containers/counter.ml b/test/irmin-containers/counter.ml index cdcac2ef97..e724c44623 100644 --- a/test/irmin-containers/counter.ml +++ b/test/irmin-containers/counter.ml @@ -23,69 +23,69 @@ let path = [ "tmp"; "counter" ] let config () = C.Store.Repo.v (Irmin_mem.config ()) let merge_into_exn = merge_into_exn (module C.Store) -let test_inc _ () = - let* t = config () >>= C.Store.main in - C.inc ~path t >>= fun () -> - let* () = +let test_inc () = + let t = config () |> C.Store.main in + C.inc ~path t; + let () = C.read ~path t - >|= Alcotest.(check int64) "checked - increment without using by" 1L + |> Alcotest.(check int64) "checked - increment without using by" 1L in - C.inc ~by:2L ~path t >>= fun () -> - C.read ~path t >|= Alcotest.(check int64) "checked - increment using by" 3L + C.inc ~by:2L ~path t; + C.read ~path t |> Alcotest.(check int64) "checked - increment using by" 3L -let test_dec _ () = - let* t = config () >>= C.Store.main in - C.dec ~path t >>= fun () -> - let* () = +let test_dec () = + let t = config () |> C.Store.main in + C.dec ~path t; + let () = C.read ~path t - >|= Alcotest.(check int64) "checked - decrement without using by" 2L + |> Alcotest.(check int64) "checked - decrement without using by" 2L in - C.dec ~by:2L ~path t >>= fun () -> - C.read ~path t >|= Alcotest.(check int64) "checked - decrement using by" 0L + C.dec ~by:2L ~path t; + C.read ~path t |> Alcotest.(check int64) "checked - decrement using by" 0L -let test_clone_merge _ () = - let* t = config () >>= C.Store.main in - C.inc ~by:5L ~path t >>= fun () -> - let* b = C.Store.clone ~src:t ~dst:"cl" in - C.inc ~by:2L ~path b >>= fun () -> - C.dec ~by:4L ~path t >>= fun () -> - let* () = - C.read ~path t >|= Alcotest.(check int64) "checked - value of main" 1L +let test_clone_merge () = + let t = config () |> C.Store.main in + C.inc ~by:5L ~path t; + let b = C.Store.clone ~src:t ~dst:"cl" in + C.inc ~by:2L ~path b; + C.dec ~by:4L ~path t; + let () = + C.read ~path t |> Alcotest.(check int64) "checked - value of main" 1L in - let* () = - C.read ~path b >|= Alcotest.(check int64) "checked - value of clone" 7L + let () = + C.read ~path b |> Alcotest.(check int64) "checked - value of clone" 7L in - merge_into_exn b ~into:t >>= fun () -> + merge_into_exn b ~into:t; C.read t ~path - >|= Alcotest.(check int64) "checked - value of main after merging" 3L + |> Alcotest.(check int64) "checked - value of main after merging" 3L -let test_branch_merge _ () = - let* r = config () in - let* b1 = C.Store.of_branch r "b1" in - let* b2 = C.Store.of_branch r "b2" in - let* b3 = C.Store.of_branch r "b3" in - let* b4 = C.Store.of_branch r "b4" in - C.inc ~by:5L ~path b1 >>= fun () -> - C.dec ~by:2L ~path b2 >>= fun () -> - merge_into_exn b1 ~into:b3 >>= fun () -> - merge_into_exn b2 ~into:b3 >>= fun () -> - merge_into_exn b2 ~into:b4 >>= fun () -> - merge_into_exn b1 ~into:b4 >>= fun () -> - let* () = - C.read ~path b3 >|= Alcotest.(check int64) "checked - value of b3" 3L +let test_branch_merge () = + let r = config () in + let b1 = C.Store.of_branch r "b1" in + let b2 = C.Store.of_branch r "b2" in + let b3 = C.Store.of_branch r "b3" in + let b4 = C.Store.of_branch r "b4" in + C.inc ~by:5L ~path b1; + C.dec ~by:2L ~path b2; + merge_into_exn b1 ~into:b3; + merge_into_exn b2 ~into:b3; + merge_into_exn b2 ~into:b4; + merge_into_exn b1 ~into:b4; + let () = + C.read ~path b3 |> Alcotest.(check int64) "checked - value of b3" 3L in - C.read ~path b4 >|= Alcotest.(check int64) "checked - value of b4" 3L + C.read ~path b4 |> Alcotest.(check int64) "checked - value of b4" 3L let test_cases = [ ( "counter", [ - Alcotest_lwt.test_case "Increment" `Quick test_inc; - Alcotest_lwt.test_case "Decrement" `Quick test_dec; + Alcotest.test_case "Increment" `Quick test_inc; + Alcotest.test_case "Decrement" `Quick test_dec; ] ); ( "counter store", [ - Alcotest_lwt.test_case "Clone and merge" `Quick test_clone_merge; - Alcotest_lwt.test_case "Branch and merge" `Quick test_branch_merge; + Alcotest.test_case "Clone and merge" `Quick test_clone_merge; + Alcotest.test_case "Branch and merge" `Quick test_branch_merge; ] ); ] diff --git a/test/irmin-containers/dune b/test/irmin-containers/dune index 1d60b6a971..3c70294ec2 100644 --- a/test/irmin-containers/dune +++ b/test/irmin-containers/dune @@ -1,6 +1,6 @@ (executable (name test) - (libraries alcotest alcotest-lwt irmin-containers)) + (libraries alcotest eio_main irmin-containers)) (rule (alias runtest) diff --git a/test/irmin-containers/linked_log.ml b/test/irmin-containers/linked_log.ml index 08d6a7241b..0609c0dcc8 100644 --- a/test/irmin-containers/linked_log.ml +++ b/test/irmin-containers/linked_log.ml @@ -30,70 +30,70 @@ let merge_into_exn = merge_into_exn (module L.Store) let path = [ "tmp"; "link" ] let config () = L.Store.Repo.v (Irmin_mem.config ()) -let test_empty_read _ () = +let test_empty_read () = config () - >>= L.Store.main - >>= L.read_all ~path - >|= Alcotest.(check (list string)) "checked - reading empty log" [] + |> L.Store.main + |> L.read_all ~path + |> Alcotest.(check (list string)) "checked - reading empty log" [] -let test_append_read_all _ () = - let* t = config () >>= L.Store.main in - L.append ~path t "main.1" >>= fun () -> - L.append ~path t "main.2" >>= fun () -> +let test_append_read_all () = + let t = config () |> L.Store.main in + L.append ~path t "main.1"; + L.append ~path t "main.2"; L.read_all ~path t - >|= Alcotest.(check (list string)) + |> Alcotest.(check (list string)) "checked - log after appending" [ "main.2"; "main.1" ] -let test_read_incr _ () = - let* cur = config () >>= L.Store.main >>= L.get_cursor ~path in - let* l, cur = L.read ~num_items:1 cur in +let test_read_incr () = + let cur = config () |> L.Store.main |> L.get_cursor ~path in + let l, cur = L.read ~num_items:1 cur in Alcotest.(check (list string)) "checked - read one item" [ "main.2" ] l; - let* l, cur = L.read ~num_items:1 cur in + let l, cur = L.read ~num_items:1 cur in Alcotest.(check (list string)) "checked - read one more item" [ "main.1" ] l; - let+ l, _ = L.read ~num_items:1 cur in + let l, _ = L.read ~num_items:1 cur in Alcotest.(check (list string)) "checked - read one more item" [] l -let test_read_excess _ () = - let* cur = config () >>= L.Store.main >>= L.get_cursor ~path in - let+ l, _ = L.read ~num_items:10 cur in +let test_read_excess () = + let cur = config () |> L.Store.main |> L.get_cursor ~path in + let l, _ = L.read ~num_items:10 cur in Alcotest.(check (list string)) "checked - read 10 items" [ "main.2"; "main.1" ] l -let test_clone_merge _ () = - let* t = config () >>= L.Store.main in - let* b = L.Store.clone ~src:t ~dst:"cl" in - L.append ~path b "clone.1" >>= fun () -> - L.append ~path t "main.3" >>= fun () -> - merge_into_exn b ~into:t >>= fun () -> +let test_clone_merge () = + let t = config () |> L.Store.main in + let b = L.Store.clone ~src:t ~dst:"cl" in + L.append ~path b "clone.1"; + L.append ~path t "main.3"; + merge_into_exn b ~into:t; L.read_all ~path t - >|= Alcotest.(check (list string)) + |> Alcotest.(check (list string)) "checked - log after appending" [ "main.3"; "clone.1"; "main.2"; "main.1" ] -let test_branch_merge _ () = - let* r = config () in - let* b1 = L.Store.of_branch r "b1" in - let* b2 = L.Store.of_branch r "b2" in - let* b3 = L.Store.of_branch r "b3" in - let* b4 = L.Store.of_branch r "b4" in - L.append ~path b1 "b1.1" >>= fun () -> - L.append ~path b2 "b2.1" >>= fun () -> - L.append ~path b1 "b1.2" >>= fun () -> - L.append ~path b1 "b1.3" >>= fun () -> - L.append ~path b2 "b2.2" >>= fun () -> - L.append ~path b1 "b1.4" >>= fun () -> - merge_into_exn b1 ~into:b3 >>= fun () -> - merge_into_exn b2 ~into:b3 >>= fun () -> - merge_into_exn b2 ~into:b4 >>= fun () -> - merge_into_exn b1 ~into:b4 >>= fun () -> - let* () = +let test_branch_merge () = + let r = config () in + let b1 = L.Store.of_branch r "b1" in + let b2 = L.Store.of_branch r "b2" in + let b3 = L.Store.of_branch r "b3" in + let b4 = L.Store.of_branch r "b4" in + L.append ~path b1 "b1.1"; + L.append ~path b2 "b2.1"; + L.append ~path b1 "b1.2"; + L.append ~path b1 "b1.3"; + L.append ~path b2 "b2.2"; + L.append ~path b1 "b1.4"; + merge_into_exn b1 ~into:b3; + merge_into_exn b2 ~into:b3; + merge_into_exn b2 ~into:b4; + merge_into_exn b1 ~into:b4; + let () = L.read_all ~path b3 - >|= Alcotest.(check (list string)) + |> Alcotest.(check (list string)) "checked - value of b3" [ "b1.4"; "b2.2"; "b1.3"; "b1.2"; "b2.1"; "b1.1" ] in L.read_all ~path b4 - >|= Alcotest.(check (list string)) + |> Alcotest.(check (list string)) "checked - value of b4" [ "b1.4"; "b2.2"; "b1.3"; "b1.2"; "b2.1"; "b1.1" ] @@ -101,15 +101,15 @@ let test_cases = [ ( "linked_log", [ - Alcotest_lwt.test_case "Read empty log" `Quick test_empty_read; - Alcotest_lwt.test_case "Append and real all" `Quick test_append_read_all; - Alcotest_lwt.test_case "Read incrementally with cursor" `Quick + Alcotest.test_case "Read empty log" `Quick test_empty_read; + Alcotest.test_case "Append and real all" `Quick test_append_read_all; + Alcotest.test_case "Read incrementally with cursor" `Quick test_read_incr; - Alcotest_lwt.test_case "Read excess with cursor" `Quick test_read_excess; + Alcotest.test_case "Read excess with cursor" `Quick test_read_excess; ] ); ( "linked_log store", [ - Alcotest_lwt.test_case "Clone and merge" `Quick test_clone_merge; - Alcotest_lwt.test_case "Branch and merge" `Quick test_branch_merge; + Alcotest.test_case "Clone and merge" `Quick test_clone_merge; + Alcotest.test_case "Branch and merge" `Quick test_branch_merge; ] ); ] diff --git a/test/irmin-containers/lww_register.ml b/test/irmin-containers/lww_register.ml index 5ab78db3c2..3010fcb8c1 100644 --- a/test/irmin-containers/lww_register.ml +++ b/test/irmin-containers/lww_register.ml @@ -30,67 +30,67 @@ let merge_into_exn = merge_into_exn (module L.Store) let path = [ "tmp"; "lww" ] let config () = L.Store.Repo.v (Irmin_mem.config ()) -let test_empty_read _ () = +let test_empty_read () = config () - >>= L.Store.main - >>= L.read ~path - >|= Alcotest.(check (option int)) + |> L.Store.main + |> L.read ~path + |> Alcotest.(check (option int)) "checked - reading register without writing" None -let test_write _ () = - let* t = config () >>= L.Store.main in - L.write ~path t 1 >>= fun () -> - L.write ~path t 3 >>= fun () -> +let test_write () = + let t = config () |> L.Store.main in + L.write ~path t 1; + L.write ~path t 3; L.read ~path t - >|= Alcotest.(check (option int)) "checked - writing to register" (Some 3) + |> Alcotest.(check (option int)) "checked - writing to register" (Some 3) -let test_clone_merge _ () = - let* t = config () >>= L.Store.main in - let* b = L.Store.clone ~src:t ~dst:"cl" in - L.write ~path t 5 >>= fun () -> - L.write ~path b 10 >>= fun () -> - let* () = +let test_clone_merge () = + let t = config () |> L.Store.main in + let b = L.Store.clone ~src:t ~dst:"cl" in + L.write ~path t 5; + L.write ~path b 10; + let () = L.read ~path t - >|= Alcotest.(check (option int)) "checked - value of main" (Some 5) + |> Alcotest.(check (option int)) "checked - value of main" (Some 5) in - let* () = + let () = L.read ~path b - >|= Alcotest.(check (option int)) "checked - value of clone" (Some 10) + |> Alcotest.(check (option int)) "checked - value of clone" (Some 10) in - merge_into_exn b ~into:t >>= fun () -> + merge_into_exn b ~into:t; L.read ~path t - >|= Alcotest.(check (option int)) + |> Alcotest.(check (option int)) "checked - value of main after merging" (Some 10) -let test_branch_merge _ () = - let* r = config () in - let* b1 = L.Store.of_branch r "b1" in - let* b2 = L.Store.of_branch r "b2" in - let* b3 = L.Store.of_branch r "b3" in - let* b4 = L.Store.of_branch r "b4" in - L.write ~path b1 6 >>= fun () -> - L.write ~path b2 3 >>= fun () -> - merge_into_exn b1 ~into:b3 >>= fun () -> - merge_into_exn b2 ~into:b3 >>= fun () -> - merge_into_exn b2 ~into:b4 >>= fun () -> - merge_into_exn b1 ~into:b4 >>= fun () -> - let* () = +let test_branch_merge () = + let r = config () in + let b1 = L.Store.of_branch r "b1" in + let b2 = L.Store.of_branch r "b2" in + let b3 = L.Store.of_branch r "b3" in + let b4 = L.Store.of_branch r "b4" in + L.write ~path b1 6; + L.write ~path b2 3; + merge_into_exn b1 ~into:b3; + merge_into_exn b2 ~into:b3; + merge_into_exn b2 ~into:b4; + merge_into_exn b1 ~into:b4; + let () = L.read ~path b3 - >|= Alcotest.(check (option int)) "checked - value of b3" (Some 3) + |> Alcotest.(check (option int)) "checked - value of b3" (Some 3) in L.read ~path b4 - >|= Alcotest.(check (option int)) "checked - value of b4" (Some 3) + |> Alcotest.(check (option int)) "checked - value of b4" (Some 3) let test_cases = [ ( "lww_register", [ - Alcotest_lwt.test_case "Read" `Quick test_empty_read; - Alcotest_lwt.test_case "Write" `Quick test_write; + Alcotest.test_case "Read" `Quick test_empty_read; + Alcotest.test_case "Write" `Quick test_write; ] ); ( "lww_register store", [ - Alcotest_lwt.test_case "Clone and merge" `Quick test_clone_merge; - Alcotest_lwt.test_case "Branch and merge" `Quick test_branch_merge; + Alcotest.test_case "Clone and merge" `Quick test_clone_merge; + Alcotest.test_case "Branch and merge" `Quick test_branch_merge; ] ); ] diff --git a/test/irmin-containers/test.ml b/test/irmin-containers/test.ml index 50483d8ed1..387715bd0e 100644 --- a/test/irmin-containers/test.ml +++ b/test/irmin-containers/test.ml @@ -16,8 +16,8 @@ *) let () = - Lwt_main.run - @@ Alcotest_lwt.run "irmin-containers" + Eio_main.run @@ fun _env -> + Alcotest.run "irmin-containers" (Counter.test_cases @ Lww_register.test_cases @ Blob_log.test_cases From 99142a892c8541b4c10509471b598fa3b331206f Mon Sep 17 00:00:00 2001 From: Patrick Ferris Date: Tue, 29 Nov 2022 11:52:59 +0000 Subject: [PATCH 09/99] Remove pin-depends for eio --- irmin.opam | 6 +----- src/irmin-chunk/irmin_chunk.ml | 2 +- 2 files changed, 2 insertions(+), 6 deletions(-) diff --git a/irmin.opam b/irmin.opam index a9cd88e61e..a6e5732f86 100644 --- a/irmin.opam +++ b/irmin.opam @@ -21,7 +21,7 @@ depends: [ "uri" {>= "1.3.12"} "uutf" "jsonm" {>= "1.0.0"} - "eio" {>= "0.2"} + "eio" {>= "0.6"} "digestif" {>= "0.9.0"} "ocamlgraph" "logs" {>= "0.5.0"} @@ -40,10 +40,6 @@ depends: [ "bisect_ppx" {dev & >= "2.5.0"} ] -pin-depends: [ - [ "eio.0.2" "git+https://github.com/TheLortex/eio#d2f0cfc08e1d9859fb56c09cb04b49bced602400" ] -] - conflicts: [ "result" {< "1.5"} # Requires `Result = Stdlib.Result` ] diff --git a/src/irmin-chunk/irmin_chunk.ml b/src/irmin-chunk/irmin_chunk.ml index 91ec83a876..635f9df703 100644 --- a/src/irmin-chunk/irmin_chunk.ml +++ b/src/irmin-chunk/irmin_chunk.ml @@ -179,7 +179,7 @@ struct in match list_partition n l with | [ i ] -> AO.add t.db key (index t i); key - | l -> Fiber.map (fun i -> CA.add t.db (index t i)) l |> aux) + | l -> Fiber.List.map (fun i -> CA.add t.db (index t i)) l |> aux) in aux l end From 169de7cb864cd4278814d46d5f6ed654fd32600c Mon Sep 17 00:00:00 2001 From: Patrick Ferris Date: Tue, 29 Nov 2022 13:22:07 +0000 Subject: [PATCH 10/99] Fix irmin-fs file info --- src/irmin-fs/unix/irmin_fs_unix.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/irmin-fs/unix/irmin_fs_unix.ml b/src/irmin-fs/unix/irmin_fs_unix.ml index adfa87d13e..1da663cdf9 100644 --- a/src/irmin-fs/unix/irmin_fs_unix.ml +++ b/src/irmin-fs/unix/irmin_fs_unix.ml @@ -98,7 +98,7 @@ module IO = struct Switch.run @@ fun sw -> let flow = Path.open_out ~sw fcap - ~create:(`If_missing 0o600) + ~create:(`Exclusive 0o600) in Flow.copy_string (string_of_int pid) flow in @@ -190,7 +190,7 @@ module IO = struct let tmp_name = Filename.basename tmp_f in Eio_pool.use openfile_pool (fun () -> [%log.debug "Writing %s (%s) %s %s" file_f tmp_f (snd temp_dir_path) (snd file)]; - Path.(with_open_out ~create:(`If_missing 0o644) (temp_dir_path / tmp_name) fn); + Path.(with_open_out ~create:(`Or_truncate 0o644) (temp_dir_path / tmp_name) fn); rename Path.(temp_dir_path / tmp_name) file) let read_file_with_read file size = From ec6f097780fc504ac2293d82bf7611f208b22091 Mon Sep 17 00:00:00 2001 From: Patrick Ferris Date: Tue, 29 Nov 2022 18:52:48 +0000 Subject: [PATCH 11/99] Fix ignoring commit in store --- dune | 2 +- src/irmin-test/dune | 3 +-- src/irmin-test/irmin_bench.ml | 30 +++++++++++++++++------------- src/irmin-test/store.ml | 4 ++-- src/irmin/store.ml | 11 +++++------ test/irmin-mem/test.ml | 1 + 6 files changed, 27 insertions(+), 24 deletions(-) diff --git a/dune b/dune index d87e5fb73c..494db1796a 100644 --- a/dune +++ b/dune @@ -1,4 +1,4 @@ -(vendored_dirs vendors irmin-watcher ocaml-inotify) +(vendored_dirs vendors irmin-watcher.dev ocaml-inotify) (mdx (files README.md) diff --git a/src/irmin-test/dune b/src/irmin-test/dune index 7b99a329ad..3cf0b8c658 100644 --- a/src/irmin-test/dune +++ b/src/irmin-test/dune @@ -32,8 +32,7 @@ irmin logs.fmt logs.cli - lwt - lwt.unix + eio_main metrics metrics-unix irmin-test) diff --git a/src/irmin-test/irmin_bench.ml b/src/irmin-test/irmin_bench.ml index 6b3872882c..bbd7494c97 100644 --- a/src/irmin-test/irmin_bench.ml +++ b/src/irmin-test/irmin_bench.ml @@ -108,9 +108,9 @@ struct let times ~n ~init f = let rec go i k = - if i = 0 then k init else go (i - 1) (fun r -> f i r >>= k) + if i = 0 then k init else go (i - 1) (fun r -> k (f i r)) in - go n Lwt.return + go n Fun.id let path ~depth n = let rec aux acc = function @@ -137,42 +137,46 @@ struct [t.tree_add] files + one directory going to the next levele. *) let init t config = let tree = Store.Tree.empty () in - let* v = Store.Repo.v config >>= Store.main in - let* tree = + let v = Store.Repo.v config |> Store.main in + let tree = times ~n:t.depth ~init:tree (fun depth tree -> let paths = Array.init (t.tree_add + 1) (path ~depth) in times ~n:t.tree_add ~init:tree (fun n tree -> Store.Tree.add tree paths.(n) "init")) in - Store.set_tree_exn v ~info [] tree >|= fun () -> Fmt.epr "[init done]\n%!" + Store.set_tree_exn v ~info [] tree; + Fmt.epr "[init done]\n%!" let run t config size = - let* r = Store.Repo.v config in - let* v = Store.main r in + let r = Store.Repo.v config in + let v = Store.main r in Store.Tree.reset_counters (); let paths = Array.init (t.tree_add + 1) (path ~depth:t.depth) in - let* () = + let () = times ~n:t.ncommits ~init:() (fun i () -> - let* tree = Store.get_tree v [] in + let tree = Store.get_tree v [] in if i mod t.gc = 0 then Gc.full_major (); if i mod t.display = 0 then ( plot_progress i t.ncommits; print_stats ~size ~commits:i); - let* tree = + let tree = times ~n:t.tree_add ~init:tree (fun n tree -> Store.Tree.add tree paths.(n) (string_of_int i)) in - Store.set_tree_exn v ~info [] tree >|= fun () -> + Store.set_tree_exn v ~info [] tree; if t.clear then Store.Tree.clear tree) in - Store.Repo.close r >|= fun () -> Fmt.epr "\n[run done]\n%!" + Store.Repo.close r; + Fmt.epr "\n[run done]\n%!" let main t config size = let root = "_build/_bench" in let config = config ~root in let size () = size ~root in let t = { t with root } in - Lwt_main.run (init t config >>= fun () -> run t config size) + Eio_main.run @@ fun _ -> + init t config; + run t config size let main_term config size = Term.(const main $ t $ const config $ const size) diff --git a/src/irmin-test/store.ml b/src/irmin-test/store.ml index 711001b852..bdb1d768e6 100644 --- a/src/irmin-test/store.ml +++ b/src/irmin-test/store.ml @@ -2107,13 +2107,13 @@ module Make (S : Generic_key) = struct let check_test e = function | Error (`Test_was e') -> Alcotest.(check (option tree_t)) "test-was" e e' - | Ok () -> Alcotest.fail "error expected" + | Ok () -> Alcotest.fail "check_test: 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" + | Ok () -> Alcotest.fail "check_conflict: error expected" | Error e -> Alcotest.failf "an other error was expected: %a" pp_write_error e in diff --git a/src/irmin/store.ml b/src/irmin/store.ml index a224c41449..7ccd11cdf0 100644 --- a/src/irmin/store.ml +++ b/src/irmin/store.ml @@ -504,8 +504,7 @@ module Make (B : Backend.S) = struct new_h] let with_tree ~key x f = - match x with - (* Hmmmm *) + match x () with | None -> skip_key key | Some x -> changed_key key None None; @@ -513,11 +512,11 @@ module Make (B : Backend.S) = struct let lift_tree_diff ~key tree fn = function | `Removed x -> - with_tree ~key (tree x) @@ fun v -> + with_tree ~key (fun () -> tree x) @@ fun v -> changed_key key (Some v) None; fn @@ `Removed (x, v) | `Added x -> - with_tree ~key (tree x) @@ fun v -> + with_tree ~key (fun () -> tree x) @@ fun v -> changed_key key None (Some v); fn @@ `Added (x, v) | `Updated (x, y) -> ( @@ -786,8 +785,8 @@ module Make (B : Backend.S) = struct | Some tree -> Tree.add_tree root key tree |> ok let ignore_commit - (_c : (commit option, [> `Too_many_retries of int ]) result) = - Ok () + (c : (commit option, [> `Too_many_retries of int ]) result) = + Result.map (fun _ -> ()) c let set_tree ?clear ?(retries = 13) ?allow_empty ?parents ~info t k v = [%log.debug "set %a" pp_path k]; diff --git a/test/irmin-mem/test.ml b/test/irmin-mem/test.ml index fde07895fc..03841d23ab 100644 --- a/test/irmin-mem/test.ml +++ b/test/irmin-mem/test.ml @@ -15,5 +15,6 @@ *) let () = + Eio_main.run @@ fun _ -> Irmin_test.Store.run "irmin-mem" ~slow:true ~misc:[] ~sleep:Eio_unix.sleep [ (`Quick, Test_mem.suite) ] From 1a2a318efc4679bbecadda095417fad0f03d4baf Mon Sep 17 00:00:00 2001 From: Patrick Ferris Date: Tue, 29 Nov 2022 18:57:19 +0000 Subject: [PATCH 12/99] Fix generic-key tests --- test/irmin/generic-key/dune | 1 + test/irmin/generic-key/test.ml | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/test/irmin/generic-key/dune b/test/irmin/generic-key/dune index b8eec5dfec..9ddd2f5348 100644 --- a/test/irmin/generic-key/dune +++ b/test/irmin/generic-key/dune @@ -6,6 +6,7 @@ (pps ppx_irmin.internal)) (libraries irmin + eio_main irmin.mem irmin-test alcotest diff --git a/test/irmin/generic-key/test.ml b/test/irmin/generic-key/test.ml index 28f52b7cea..5f6c18447c 100644 --- a/test/irmin/generic-key/test.ml +++ b/test/irmin/generic-key/test.ml @@ -15,8 +15,8 @@ *) let () = - Lwt_main.run - @@ Irmin_test.Store.run __FILE__ ~slow:true ~misc:[] ~sleep:Lwt_unix.sleep + Eio_main.run @@ fun _env -> + Irmin_test.Store.run __FILE__ ~slow:true ~misc:[] ~sleep:Eio_unix.sleep [ (`Quick, Test_store_offset.suite); (`Quick, Test_inlined_contents.suite); ] From adfa85ee2a3a7cb5d7db9d8fa4ddf39841330050 Mon Sep 17 00:00:00 2001 From: Patrick Ferris Date: Fri, 9 Dec 2022 21:45:56 +0000 Subject: [PATCH 13/99] Remove traceln --- src/irmin-fs/irmin_fs.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/src/irmin-fs/irmin_fs.ml b/src/irmin-fs/irmin_fs.ml index 88f90685ce..44e6b8af7f 100644 --- a/src/irmin-fs/irmin_fs.ml +++ b/src/irmin-fs/irmin_fs.ml @@ -83,7 +83,6 @@ struct let v config = let fs = Irmin.Backend.Conf.Env.fs () in let path = Path.(fs / get_path config) in - Eio.traceln "%a" Path.pp path; IO.mkdir path; { path } From 0d484c1ccaa528c9b231b42c1d5a3f0ec9a08ebd Mon Sep 17 00:00:00 2001 From: Patrick Ferris Date: Tue, 10 Jan 2023 19:51:56 +0000 Subject: [PATCH 14/99] Update to eio.0.7 and catch IO errors --- src/irmin-chunk/irmin_chunk.ml | 21 ++-- src/irmin-containers/linked_log.ml | 2 +- src/irmin-containers/linked_log.mli | 2 +- src/irmin-containers/lww_register.ml | 4 +- src/irmin-containers/lww_register.mli | 3 +- src/irmin-fs/irmin_fs.ml | 22 +++-- src/irmin-fs/irmin_fs.mli | 2 +- src/irmin-fs/unix/eio_pool.ml | 118 ++++++++++++----------- src/irmin-fs/unix/irmin_fs_unix.ml | 132 ++++++++++++++------------ src/irmin-pack/unix/async.ml | 2 +- src/irmin-pack/unix/gc.ml | 2 +- src/irmin-pack/unix/gc_args.ml | 2 +- src/irmin-pack/unix/pack_store.ml | 4 +- src/irmin-test/common.ml | 76 +++++++-------- src/irmin-test/irmin_bench.ml | 2 +- src/irmin-test/store_watch.ml | 6 +- src/irmin/conf.ml | 5 +- src/irmin/conf.mli | 5 +- src/irmin/store.ml | 10 +- src/irmin/tree.ml | 3 +- src/irmin/tree_intf.ml | 7 +- src/irmin/watch.ml | 4 +- test/irmin-chunk/test.ml | 4 +- test/irmin-containers/blob_log.ml | 14 +-- test/irmin-containers/common.mli | 3 +- test/irmin-containers/linked_log.ml | 14 +-- test/irmin-containers/lww_register.ml | 4 +- test/irmin-containers/test.ml | 8 +- test/irmin-fs/test.ml | 2 +- test/irmin-fs/test_unix.ml | 4 +- test/irmin-mem/test.ml | 2 +- test/irmin-pack/common.ml | 2 +- test/irmin-pack/common.mli | 8 +- test/irmin-pack/test.ml | 5 +- test/irmin-pack/test_corrupted.ml | 6 +- test/irmin-pack/test_gc.ml | 4 +- test/irmin-pack/test_gc.mli | 6 +- test/irmin-pack/test_inode.ml | 5 +- test/irmin-pack/test_nearest_leq.ml | 3 +- test/irmin-pack/test_pack.ml | 15 ++- test/irmin-pack/test_snapshot.ml | 4 +- test/irmin-pack/test_upgrade.ml | 14 +-- test/irmin/generic-key/dune | 8 +- test/irmin/generic-key/test.ml | 4 +- 44 files changed, 287 insertions(+), 286 deletions(-) diff --git a/src/irmin-chunk/irmin_chunk.ml b/src/irmin-chunk/irmin_chunk.ml index 635f9df703..a8331dddf0 100644 --- a/src/irmin-chunk/irmin_chunk.ml +++ b/src/irmin-chunk/irmin_chunk.ml @@ -151,9 +151,7 @@ struct | Chunk.Index i -> List.fold_left (fun acc key -> - match CA.find t.db key with - | None -> acc - | Some v -> aux acc v) + match CA.find t.db key with None -> acc | Some v -> aux acc v) acc i in aux [] root |> List.rev @@ -178,7 +176,9 @@ struct else List.length l in match list_partition n l with - | [ i ] -> AO.add t.db key (index t i); key + | [ i ] -> + AO.add t.db key (index t i); + key | l -> Fiber.List.map (fun i -> CA.add t.db (index t i)) l |> aux) in aux l @@ -212,8 +212,8 @@ struct let k' = H.hash (pre_hash_value v) in if equal_key k k' then () else - Fmt.kstr failwith "corrupted value: got %a, expecting %a" - pp_key k' pp_key k + Fmt.kstr failwith "corrupted value: got %a, expecting %a" pp_key k' pp_key + k let find t key = match find_leaves t key with @@ -221,7 +221,9 @@ struct | Some bufs -> ( let buf = String.concat "" bufs in match value_of_bin_string buf with - | Ok va -> check_hash key va; Some va + | Ok va -> + check_hash key va; + Some va | Error _ -> None) let list_range ~init ~stop ~step = @@ -232,10 +234,9 @@ struct let unsafe_add_buffer t key buf = let len = String.length buf in - if len <= t.max_data then begin + if len <= t.max_data then ( AO.add t.db key (data t buf); - [%log.debug "add -> %a (no split)" pp_key key] - end + [%log.debug "add -> %a (no split)" pp_key key]) else let offs = list_range ~init:0 ~stop:len ~step:t.max_data in let aux off = diff --git a/src/irmin-containers/linked_log.ml b/src/irmin-containers/linked_log.ml index a5c2a77dc1..1bcb7d3143 100644 --- a/src/irmin-containers/linked_log.ml +++ b/src/irmin-containers/linked_log.ml @@ -89,7 +89,7 @@ module type S = sig type cursor val get_cursor : path:Store.path -> Store.t -> cursor - val read : num_items:int -> cursor -> (value list * cursor) + val read : num_items:int -> cursor -> value list * cursor end module Make diff --git a/src/irmin-containers/linked_log.mli b/src/irmin-containers/linked_log.mli index 5b6005bd2f..16f20d270f 100644 --- a/src/irmin-containers/linked_log.mli +++ b/src/irmin-containers/linked_log.mli @@ -33,7 +33,7 @@ module type S = sig val get_cursor : path:Store.path -> Store.t -> cursor (** Create a new cursor over the log entires at the given path *) - val read : num_items:int -> cursor -> (value list * cursor) + val read : num_items:int -> cursor -> value list * cursor (** Read at most [num_items] entries from the cursor. If the number specified is greater than the number of log entries from the cursor, the log is read till the end. If the input cursor has already reached the end, then an diff --git a/src/irmin-containers/lww_register.ml b/src/irmin-containers/lww_register.ml index 6a7fb625be..b8144fd9fe 100644 --- a/src/irmin-containers/lww_register.ml +++ b/src/irmin-containers/lww_register.ml @@ -41,9 +41,7 @@ module type S = sig type value val read : path:Store.path -> Store.t -> value option - - val write : - ?info:Store.Info.f -> path:Store.path -> Store.t -> value -> unit + val write : ?info:Store.Info.f -> path:Store.path -> Store.t -> value -> unit end module Make (Backend : Irmin.KV_maker) (T : Time.S) (V : Irmin.Type.S) = struct diff --git a/src/irmin-containers/lww_register.mli b/src/irmin-containers/lww_register.mli index 3b748cecd5..472a66dd6e 100644 --- a/src/irmin-containers/lww_register.mli +++ b/src/irmin-containers/lww_register.mli @@ -34,8 +34,7 @@ module type S = sig val read : path:Store.path -> Store.t -> value option (** Reads the value from the register. Returns [None] if no value is written *) - val write : - ?info:Store.Info.f -> path:Store.path -> Store.t -> value -> unit + val write : ?info:Store.Info.f -> path:Store.path -> Store.t -> value -> unit (** Writes the provided value to the register *) end diff --git a/src/irmin-fs/irmin_fs.ml b/src/irmin-fs/irmin_fs.ml index 44e6b8af7f..4aceb32ca7 100644 --- a/src/irmin-fs/irmin_fs.ml +++ b/src/irmin-fs/irmin_fs.ml @@ -307,11 +307,11 @@ module Obj = struct let file_of_key k = let pre = String.with_range k ~len:2 in let suf = String.with_range k ~first:2 in - let ( / ) = Filename.concat in + let ( / ) = Filename.concat in "objects" / pre / suf let key_of_file path = - let ( / ) = Filename.concat in + let ( / ) = Filename.concat in let path = string_chop_prefix ~prefix:("objects" / "") path in let path = String.cuts ~sep:Filename.dir_sep path in let path = String.concat ~sep:"" path in @@ -372,7 +372,8 @@ module IO_mem = struct let rec_files (_, dir) = Hashtbl.fold - (fun ((_, k) as v) _ acc -> if String.is_prefix ~affix:dir k then v :: acc else acc) + (fun ((_, k) as v) _ acc -> + if String.is_prefix ~affix:dir k then v :: acc else acc) t.files [] let file_exists file = Hashtbl.mem t.files file @@ -427,9 +428,12 @@ let run (fs : Fs.dir Path.t) fn = Switch.run @@ fun sw -> Irmin.Backend.Watch.set_watch_switch sw; let open Effect.Deep in - try_with fn () { - effc = fun (type a) (e : a Effect.t) -> - match e with - | Irmin.Backend.Conf.Env.Fs -> Some (fun (k : (a, _) continuation) -> continue k fs) - | _ -> None - } \ No newline at end of file + try_with fn () + { + effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Irmin.Backend.Conf.Env.Fs -> + Some (fun (k : (a, _) continuation) -> continue k fs) + | _ -> None); + } diff --git a/src/irmin-fs/irmin_fs.mli b/src/irmin-fs/irmin_fs.mli index ffdb304947..65b3ba679e 100644 --- a/src/irmin-fs/irmin_fs.mli +++ b/src/irmin-fs/irmin_fs.mli @@ -109,4 +109,4 @@ module IO_mem : sig val set_listen_hook : unit -> unit end -val run : Eio.Fs.dir Eio.Path.t -> (unit -> 'a) -> 'a \ No newline at end of file +val run : Eio.Fs.dir Eio.Path.t -> (unit -> 'a) -> 'a diff --git a/src/irmin-fs/unix/eio_pool.ml b/src/irmin-fs/unix/eio_pool.ml index a74bbf7348..e32c122638 100644 --- a/src/irmin-fs/unix/eio_pool.ml +++ b/src/irmin-fs/unix/eio_pool.ml @@ -18,39 +18,45 @@ type 'a t = { list : 'a Queue.t; (* Available pool members. *) waiters : ('a, exn) result Promise.u Stream.t; - (* Promise resolvers waiting for a free member. *) + (* Promise resolvers waiting for a free member. *) } -let create m ?(validate = fun _ -> true) ?(check = fun _ f -> f true) ?(dispose = fun _ -> ()) create = - { max = m; - create = create; - validate = validate; - check = check; - dispose = dispose; +let create m ?(validate = fun _ -> true) ?(check = fun _ f -> f true) + ?(dispose = fun _ -> ()) create = + { + max = m; + create; + validate; + check; + dispose; cleared = ref (ref false); count = 0; list = Queue.create (); - waiters = Stream.create m } + waiters = Stream.create m; + } + (* Create a pool member. *) let create_member p = try - (* Must be done before p.create to prevent other resolvers from - creating new members if the limit is reached. *) - p.count <- p.count + 1; - p.create () + (* Must be done before p.create to prevent other resolvers from + creating new members if the limit is reached. *) + p.count <- p.count + 1; + p.create () with exn -> - (* Creation failed, so don't increment count. *) - p.count <- p.count - 1; - raise exn + (* Creation failed, so don't increment count. *) + p.count <- p.count - 1; + raise exn + (* Release a pool member. *) let release p c = match Stream.take_nonblocking p.waiters with | Some wakener -> - (* A promise resolver is waiting, give it the pool member. *) - Promise.resolve_ok wakener c + (* A promise resolver is waiting, give it the pool member. *) + Promise.resolve_ok wakener c | None -> - (* No one is waiting, queue it. *) - Queue.push c p.list + (* No one is waiting, queue it. *) + Queue.push c p.list + (* Dispose of a pool member. *) let dispose p c = p.dispose c; @@ -61,68 +67,68 @@ let dispose p c = let replace_disposed p = match Stream.take_nonblocking p.waiters with | None -> - (* No one is waiting, do not create a new member to avoid - losing an error if creation fails. *) - () - | Some wakener -> - match p.create () with - | c -> Promise.resolve_ok wakener c - | exception exn -> - (* Creation failed, notify the waiter of the failure. *) - Promise.resolve_error wakener exn + (* No one is waiting, do not create a new member to avoid + losing an error if creation fails. *) + () + | Some wakener -> ( + match p.create () with + | c -> Promise.resolve_ok wakener c + | exception exn -> + (* Creation failed, notify the waiter of the failure. *) + Promise.resolve_error wakener exn) + (* Verify a member is still valid before using it. *) let validate_and_return p c = match p.validate c with - | true -> c - | false -> - (* Remove this member and create a new one. *) - dispose p c; - create_member p - | exception e -> - (* Validation failed: create a new member if at least one - resolver is waiting. *) - dispose p c; - replace_disposed p; - raise e + | true -> c + | false -> + (* Remove this member and create a new one. *) + dispose p c; + create_member p + | exception e -> + (* Validation failed: create a new member if at least one + resolver is waiting. *) + dispose p c; + replace_disposed p; + raise e (* Acquire a pool member. *) let acquire p = - if Queue.is_empty p.list then - (* No more available member. *) - if p.count < p.max then + if Queue.is_empty p.list then ( + if (* No more available member. *) + p.count < p.max then (* Limit not reached: create a new one. *) create_member p else (* Limit reached: wait for a free one. *) - let promise, resolver = Promise.create () in + let promise, resolver = Promise.create () in Stream.add p.waiters resolver; validate_and_return p (Promise.await_exn promise) - (* (Lwt.add_task_r [@ocaml.warning "-3"]) p.waiters >>= validate_and_return p *) + (* (Lwt.add_task_r [@ocaml.warning "-3"]) p.waiters >>= validate_and_return p *)) else (* Take the first free member and validate it. *) let c = Queue.take p.list in validate_and_return p c + (* Release a member when use resulted in failed promise if the member is still valid. *) let check_and_release p c cleared = let ok = ref false in p.check c (fun result -> ok := result); - if cleared || not !ok then ( + if cleared || not !ok then (* Element is not ok or the pool was cleared - dispose of it *) dispose p c - ) - else ( - (* Element is ok - release it back to the pool *) + else (* Element is ok - release it back to the pool *) release p c - ) + let use p f = let c = acquire p in (* Capture the current cleared state so we can see if it changes while this element is in use *) let cleared = !(p.cleared) in let promise () = - try f c with - | e -> + try f c + with e -> check_and_release p c !cleared; raise e in @@ -130,12 +136,11 @@ let use p f = if !cleared then ( (* p was cleared while promise was resolving - dispose of this element *) dispose p c; - r - ) + r) else ( release p c; - r - ) + r) + let clear p = let elements = Queue.fold (fun l element -> element :: l) [] p.list in Queue.clear p.list; @@ -144,4 +149,5 @@ let clear p = old_cleared := true; p.cleared := ref false; List.iter (dispose p) elements -let wait_queue_length p = Stream.length p.waiters \ No newline at end of file + +let wait_queue_length p = Stream.length p.waiters diff --git a/src/irmin-fs/unix/irmin_fs_unix.ml b/src/irmin-fs/unix/irmin_fs_unix.ml index 1da663cdf9..6914a4a056 100644 --- a/src/irmin-fs/unix/irmin_fs_unix.ml +++ b/src/irmin-fs/unix/irmin_fs_unix.ml @@ -51,38 +51,38 @@ module IO = struct let mkdir dirname = let rec aux ((_, path) as dir) = if Sys.file_exists path && Sys.is_directory path then () - else begin + else ( if Sys.file_exists path then ( [%log.debug "%s already exists but is a file, removing." path]; safe Path.unlink dir); let parent = (fst dir, Filename.dirname @@ snd dir) in aux parent; [%log.debug "mkdir %s" path]; - protect (Path.mkdir ~perm:0o755) dir - end + protect (Path.mkdir ~perm:0o755) dir) in (* TODO: Pool *) Eio_pool.use mkdir_pool (fun () -> aux dirname) let file_exists (_, f) = - try Sys.file_exists f with - (* See https://github.com/ocsigen/lwt/issues/316 *) - | Unix.Unix_error (Unix.ENOTDIR, _, _) -> false - | e -> raise e + try Sys.file_exists f with + (* See https://github.com/ocsigen/lwt/issues/316 *) + | Unix.Unix_error (Unix.ENOTDIR, _, _) -> false + | e -> raise e module Lock = struct let is_stale max_age file = try - let s = Eio_unix.run_in_systhread (fun () -> Unix.stat file) in - if s.Unix.st_mtime < 1.0 (* ??? *) then false - else Unix.gettimeofday () -. s.Unix.st_mtime > max_age - with - | Unix.Unix_error (Unix.ENOENT, _, _) -> false - | e -> raise e + let s = Eio_unix.run_in_systhread (fun () -> Unix.stat file) in + if s.Unix.st_mtime < 1.0 (* ??? *) then false + else Unix.gettimeofday () -. s.Unix.st_mtime > max_age + with + | Unix.Unix_error (Unix.ENOENT, _, _) -> false + | e -> raise e let unlock file = Path.unlink file - let lock ?(max_age = 10. *. 60. (* 10 minutes *)) ?(sleep = 0.001) ((_, file) as fcap) = + let lock ?(max_age = 10. *. 60. (* 10 minutes *)) ?(sleep = 0.001) + ((_, file) as fcap) = let rec aux i = [%log.debug "lock %s %d" file i]; let is_stale = is_stale max_age file in @@ -96,29 +96,29 @@ module IO = struct let parent = (fst fcap, Filename.dirname file) in mkdir parent; Switch.run @@ fun sw -> - let flow = - Path.open_out ~sw fcap - ~create:(`Exclusive 0o600) - in + let flow = Path.open_out ~sw fcap ~create:(`Exclusive 0o600) in Flow.copy_string (string_of_int pid) flow in try create () with - | Unix.Unix_error (Unix.EEXIST, _, _) -> - let backoff = - 1. - +. Random.float - (let i = float i in - i *. i) - in - Eio_unix.sleep (sleep *. backoff); aux (i + 1) - | e -> raise e + | Eio.Io (Fs.E (Fs.Already_exists _), _) -> + let backoff = + 1. + +. Random.float + (let i = float i in + i *. i) + in + Eio_unix.sleep (sleep *. backoff); + aux (i + 1) + | e -> raise e in aux 1 let with_lock file fn = match file with | None -> fn () - | Some f -> lock f; Fun.protect fn ~finally:(fun () -> unlock f) + | Some f -> + lock f; + Fun.protect fn ~finally:(fun () -> unlock f) end type path = Eio.Fs.dir Eio.Path.t @@ -133,13 +133,15 @@ module IO = struct if Sys.file_exists dir && Sys.is_directory dir then let d = Path.read_dir v in let d = List.sort String.compare d in - let d = List.map (Path.(/) v) d in + let d = List.map (Path.( / ) v) d in let d = List.filter kind d in d else [] let directories dir = - list_files (fun (_, f) -> try Sys.is_directory f with Sys_error _ -> false) dir + list_files + (fun (_, f) -> try Sys.is_directory f with Sys_error _ -> false) + dir let files dir = list_files @@ -166,38 +168,45 @@ module IO = struct let remove_file ?lock ((_, file) as f) = Lock.with_lock lock (fun () -> try Path.unlink f with - (* On Windows, [EACCES] can also occur in an attempt to - rename a file or directory or to remove an existing - directory. *) - | Unix.Unix_error (Unix.EACCES, _, _) - | Unix.Unix_error (Unix.EISDIR, _, _) -> - remove_dir file - | Unix.Unix_error (Unix.ENOENT, _, _) | Fs.Not_found _ -> () - | e -> raise e) + (* On Windows, [EACCES] can also occur in an attempt to + rename a file or directory or to remove an existing + directory. *) + | Unix.Unix_error (Unix.EACCES, _, _) + | Unix.Unix_error (Unix.EISDIR, _, _) + | Eio.Io (Eio.Exn.X (Eio_unix.Unix_error (Unix.EACCES, _, _)), _) + | Eio.Io (Eio.Exn.X (Eio_unix.Unix_error (Unix.EISDIR, _, _)), _) -> + remove_dir file + | Unix.Unix_error (Unix.ENOENT, _, _) + | Eio.Io (Eio.Fs.E (Fs.Not_found _), _) -> + () + | e -> raise e) let rename tmp file = Path.rename tmp file let with_write_file ?temp_dir file fn = - let () = - match temp_dir with None -> () | Some d -> mkdir d - in + let () = match temp_dir with None -> () | Some d -> mkdir d in let dir = (fst file, Filename.dirname @@ snd file) in mkdir dir; let temp_dir_path = Option.get temp_dir in let temp_dir = snd temp_dir_path in let file_f = snd file in - let tmp_f = Filename.temp_file ~temp_dir (Filename.basename file_f) "write" in + let tmp_f = + Filename.temp_file ~temp_dir (Filename.basename file_f) "write" + in let tmp_name = Filename.basename tmp_f in Eio_pool.use openfile_pool (fun () -> - [%log.debug "Writing %s (%s) %s %s" file_f tmp_f (snd temp_dir_path) (snd file)]; - Path.(with_open_out ~create:(`Or_truncate 0o644) (temp_dir_path / tmp_name) fn); + [%log.debug + "Writing %s (%s) %s %s" file_f tmp_f (snd temp_dir_path) (snd file)]; + Path.( + with_open_out ~create:(`Or_truncate 0o644) (temp_dir_path / tmp_name) + fn); rename Path.(temp_dir_path / tmp_name) file) let read_file_with_read file size = (* let chunk_size = max 4096 (min size 0x100000) in *) let buf = Cstruct.create size in (* let flags = [ Unix.O_RDONLY ] in - let perm = 0o0 in *) + let perm = 0o0 in *) (* let* fd = Lwt_unix.openfile file flags perm in *) Path.with_open_in file @@ fun flow -> try @@ -208,29 +217,30 @@ module IO = struct let read_file_with_mmap file = let open Bigarray in let fd = Unix.(openfile file [ O_RDONLY; O_NONBLOCK ] 0o644) in - let ba = + let ba = Unix.map_file fd char c_layout false [| -1 |] |> Bigarray.array1_of_genarray in Unix.close fd; (* XXX(samoht): ideally we should not do a copy here. *) - (Bigstringaf.to_string ba) + Bigstringaf.to_string ba let read_file file = let file_f = snd file in try - Eio_pool.use openfile_pool (fun () -> - [%log.debug "Reading %s" file_f]; - let stats = Unix.stat file_f in - let size = stats.Unix.st_size in - let buf = - if size >= mmap_threshold then read_file_with_mmap file_f - else read_file_with_read file size - in - Some buf) - with - | Unix.Unix_error _ | Sys_error _ -> None | e -> raise e + Eio_pool.use openfile_pool (fun () -> + [%log.debug "Reading %s" file_f]; + let stats = Unix.stat file_f in + let size = stats.Unix.st_size in + let buf = + if size >= mmap_threshold then read_file_with_mmap file_f + else read_file_with_read file size + in + Some buf) + with + | Unix.Unix_error _ | Sys_error _ -> None + | e -> raise e let write_file ?temp_dir ?lock file b = let write () = @@ -238,8 +248,10 @@ module IO = struct in Lock.with_lock lock (fun () -> try write () with - | Unix.Unix_error (Unix.EISDIR, _, _) -> remove_dir (snd file); write () - | e -> raise e) + | Unix.Unix_error (Unix.EISDIR, _, _) -> + remove_dir (snd file); + write () + | e -> raise e) let test_and_set_file ?temp_dir ~lock file ~test ~set = Lock.with_lock (Some lock) (fun () -> diff --git a/src/irmin-pack/unix/async.ml b/src/irmin-pack/unix/async.ml index 103815411c..e26f60fb6a 100644 --- a/src/irmin-pack/unix/async.ml +++ b/src/irmin-pack/unix/async.ml @@ -61,7 +61,7 @@ module Unix = struct match Unix.fork () with | 0 -> (* Lwt_main.Exit_hooks.remove_all (); - Lwt_main.abandon_yielded_and_paused (); *) + Lwt_main.abandon_yielded_and_paused (); *) let exit_code = match f () with | () -> Exit_code.success diff --git a/src/irmin-pack/unix/gc.ml b/src/irmin-pack/unix/gc.ml index 2a7008b477..944fa649a4 100644 --- a/src/irmin-pack/unix/gc.ml +++ b/src/irmin-pack/unix/gc.ml @@ -262,7 +262,7 @@ module Make (Args : Gc_args.S) = struct in let result = - let (let*) = Result.bind in + let ( let* ) = Result.bind in match (status, gc_output) with | `Success, Ok gc_results -> let partial_stats = diff --git a/src/irmin-pack/unix/gc_args.ml b/src/irmin-pack/unix/gc_args.ml index 197d3bea4d..3441c51319 100644 --- a/src/irmin-pack/unix/gc_args.ml +++ b/src/irmin-pack/unix/gc_args.ml @@ -80,4 +80,4 @@ module type S = sig and type dict = Fm.Dict.t and type dispatcher = Dispatcher.t and type hash = hash -end \ No newline at end of file +end diff --git a/src/irmin-pack/unix/pack_store.ml b/src/irmin-pack/unix/pack_store.ml index b6cef955fa..019ffe29d2 100644 --- a/src/irmin-pack/unix/pack_store.ml +++ b/src/irmin-pack/unix/pack_store.ml @@ -436,9 +436,7 @@ struct in raise exn in - match f (cast t) with - | v -> on_success v - | exception exn -> on_fail exn + match f (cast t) with v -> on_success v | exception exn -> on_fail exn let unsafe_append ~ensure_unique ~overcommit t hash v = let kind = Val.kind v in diff --git a/src/irmin-test/common.ml b/src/irmin-test/common.ml index 6465908d3d..6214630604 100644 --- a/src/irmin-test/common.ml +++ b/src/irmin-test/common.ml @@ -218,45 +218,45 @@ module Make_helpers (S : Generic_key) = struct let repo_ptr = ref None in let config_ptr = ref None in try - 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 + 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 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 - with 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 -> () - in - let () = - match !config_ptr with - | Some config -> ignore_thunk_errors (fun () -> x.clean ~config) - | None ->() - in - Printexc.raise_with_backtrace exn bt + 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 + with 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 -> () + in + let () = + match !config_ptr with + | Some config -> ignore_thunk_errors (fun () -> x.clean ~config) + | None -> () + in + Printexc.raise_with_backtrace exn bt end let filter_src src = diff --git a/src/irmin-test/irmin_bench.ml b/src/irmin-test/irmin_bench.ml index bbd7494c97..55668da67d 100644 --- a/src/irmin-test/irmin_bench.ml +++ b/src/irmin-test/irmin_bench.ml @@ -174,7 +174,7 @@ struct let config = config ~root in let size () = size ~root in let t = { t with root } in - Eio_main.run @@ fun _ -> + Eio_main.run @@ fun _ -> init t config; run t config size diff --git a/src/irmin-test/store_watch.ml b/src/irmin-test/store_watch.ml index 3bb94cf1d4..707e654d3b 100644 --- a/src/irmin-test/store_watch.ml +++ b/src/irmin-test/store_watch.ml @@ -195,9 +195,7 @@ module Make (Log : Logs.LOG) (Zzz : Sleep) (S : Generic_key) = struct else Alcotest.failf "%s: %a / %a" msg pp a pp b) let process ?sleep_t t head = - let () = - match sleep_t with None -> () | Some s -> Zzz.sleep s - in + let () = match sleep_t with None -> () | Some s -> Zzz.sleep s in let () = match head with | `Added _ -> add t @@ -372,6 +370,6 @@ module Make (Log : Logs.LOG) (Zzz : Sleep) (S : Generic_key) = struct TODO: work out why, fix it, and re-enable it. See https://github.com/mirage/irmin/issues/1447. *) let _ = ("Basic operations", test_watches) in - let _ = [ ("Callbacks and exceptions", test_watch_exn) ] in + let _ = [ ("Callbacks and exceptions", test_watch_exn) ] in [] end diff --git a/src/irmin/conf.ml b/src/irmin/conf.ml index 6fd92b8e03..f40adc9d5f 100644 --- a/src/irmin/conf.ml +++ b/src/irmin/conf.ml @@ -180,11 +180,10 @@ let find_root (spec, d) : string option = match v with None -> None | Some v -> Some (Type.to_string k.ty v)) module Env = struct - - type _ Effect.t += + type _ Effect.t += | Fs : Eio.Fs.dir Eio.Path.t Effect.t | Net : Eio.Net.t Effect.t let fs () = Effect.perform Fs let net () = Effect.perform Net -end \ No newline at end of file +end diff --git a/src/irmin/conf.mli b/src/irmin/conf.mli index 67d22e22a5..23a98e49e2 100644 --- a/src/irmin/conf.mli +++ b/src/irmin/conf.mli @@ -168,11 +168,10 @@ val find_root : t -> string option (** [find_root c] is [root]'s mapping in [c], if any. *) module Env : sig - - type _ Effect.t += + type _ Effect.t += | Fs : Eio.Fs.dir Eio.Path.t Effect.t | Net : Eio.Net.t Effect.t val fs : unit -> Eio.Fs.dir Eio.Path.t val net : unit -> Eio.Net.t -end \ No newline at end of file +end diff --git a/src/irmin/store.ml b/src/irmin/store.ml index 7ccd11cdf0..522eb29364 100644 --- a/src/irmin/store.ml +++ b/src/irmin/store.ml @@ -628,7 +628,8 @@ module Make (B : Backend.S) = struct ~set:(h set) let test_and_set t ~test ~set = - Eio.Mutex.use_rw ~protect:true t.lock (fun () -> test_and_set_unsafe t ~test ~set) + Eio.Mutex.use_rw ~protect:true t.lock (fun () -> + test_and_set_unsafe t ~test ~set) let fast_forward t ?max_depth ?n new_head = let return x = if x then Ok () else Error (`Rejected :> ff_error) in @@ -673,7 +674,8 @@ module Make (B : Backend.S) = struct let c3 = Commit.of_key t.repo c3 in test_and_set_unsafe t ~test:head ~set:c3 |> Merge.ok in - Eio.Mutex.use_rw ~protect:true t.lock (fun () -> retry_merge "merge_head" aux) + Eio.Mutex.use_rw ~protect:true t.lock (fun () -> + retry_merge "merge_head" aux) end (* Retry an operation until the optimistic lock is happy. Ensure @@ -784,8 +786,8 @@ module Make (B : Backend.S) = struct | None -> Tree.remove root key |> ok | Some tree -> Tree.add_tree root key tree |> ok - let ignore_commit - (c : (commit option, [> `Too_many_retries of int ]) result) = + let ignore_commit (c : (commit option, [> `Too_many_retries of int ]) result) + = Result.map (fun _ -> ()) c let set_tree ?clear ?(retries = 13) ?allow_empty ?parents ~info t k v = diff --git a/src/irmin/tree.ml b/src/irmin/tree.ml index 902ef2f832..d8276638c5 100644 --- a/src/irmin/tree.ml +++ b/src/irmin/tree.ml @@ -1413,8 +1413,7 @@ module Make (P : Backend.S) = struct | Some (`Lt depth) -> if d < depth - 1 then apply acc |> next else apply acc |> k | Some (`Ge depth) -> if d < depth then next acc else apply acc |> next - | Some (`Gt depth) -> - if d <= depth then next acc else apply acc |> next + | Some (`Gt depth) -> if d <= depth then next acc else apply acc |> next and aux_uniq : type r. (t, acc, r) cps_folder = fun ~path acc d t k -> if uniq = `False then (aux [@tailcall]) ~path acc d t k diff --git a/src/irmin/tree_intf.ml b/src/irmin/tree_intf.ml index 85c45c1e91..cd572d23af 100644 --- a/src/irmin/tree_intf.ml +++ b/src/irmin/tree_intf.ml @@ -177,12 +177,7 @@ module type S = sig the parameter. *) val seq : - t -> - ?offset:int -> - ?length:int -> - ?cache:bool -> - path -> - (step * t) Seq.t + t -> ?offset:int -> ?length:int -> ?cache:bool -> path -> (step * t) Seq.t (** [seq t key] follows the same behavior as {!list} but returns a sequence. *) val get : t -> path -> contents diff --git a/src/irmin/watch.ml b/src/irmin/watch.ml index 39b97581de..91496c8814 100644 --- a/src/irmin/watch.ml +++ b/src/irmin/watch.ml @@ -61,7 +61,9 @@ let scheduler () = (s, Eio.Stream.add s) in incr workers_r; - let sw = try Option.get !watch_switch with _ -> failwith "Big Yikes" in + let sw = + try Option.get !watch_switch with _ -> failwith "Big Yikes" + in (Eio.Fiber.fork ~sw @@ fun () -> stream_iter (fun f -> f ()) stream); (* Lwt.async (fun () -> (* FIXME: we would like to skip some updates if more recent ones diff --git a/test/irmin-chunk/test.ml b/test/irmin-chunk/test.ml index 082f69aff2..e817be0574 100644 --- a/test/irmin-chunk/test.ml +++ b/test/irmin-chunk/test.ml @@ -79,5 +79,5 @@ let stable = let () = Eio_main.run @@ fun _env -> Irmin_test.Store.run "irmin-chunk" ~slow:true ~misc:[ simple; stable ] - ~sleep:Eio_unix.sleep - [ (`Quick, Test_chunk.suite) ] + ~sleep:Eio_unix.sleep + [ (`Quick, Test_chunk.suite) ] diff --git a/test/irmin-containers/blob_log.ml b/test/irmin-containers/blob_log.ml index eafaa0f1b9..23e9e71435 100644 --- a/test/irmin-containers/blob_log.ml +++ b/test/irmin-containers/blob_log.ml @@ -35,7 +35,7 @@ let test_append () = B.append ~path t "main.2"; B.read_all ~path t |> Alcotest.(check (list string)) - "checked - log after appending" [ "main.2"; "main.1" ] + "checked - log after appending" [ "main.2"; "main.1" ] let test_clone_merge () = let t = config () |> B.Store.main in @@ -45,8 +45,8 @@ let test_clone_merge () = merge_into_exn b ~into:t; B.read_all ~path t |> Alcotest.(check (list string)) - "checked - log after appending" - [ "main.3"; "clone.1"; "main.2"; "main.1" ] + "checked - log after appending" + [ "main.3"; "clone.1"; "main.2"; "main.1" ] let test_branch_merge () = let r = config () in @@ -67,13 +67,13 @@ let test_branch_merge () = let () = B.read_all ~path b3 |> Alcotest.(check (list string)) - "checked - value of b3" - [ "b1.4"; "b2.2"; "b1.3"; "b1.2"; "b2.1"; "b1.1" ] + "checked - value of b3" + [ "b1.4"; "b2.2"; "b1.3"; "b1.2"; "b2.1"; "b1.1" ] in B.read_all ~path b4 |> Alcotest.(check (list string)) - "checked - value of b4" - [ "b1.4"; "b2.2"; "b1.3"; "b1.2"; "b2.1"; "b1.1" ] + "checked - value of b4" + [ "b1.4"; "b2.2"; "b1.3"; "b1.2"; "b2.1"; "b1.1" ] let test_cases = [ diff --git a/test/irmin-containers/common.mli b/test/irmin-containers/common.mli index db11c2d284..1ace834a09 100644 --- a/test/irmin-containers/common.mli +++ b/test/irmin-containers/common.mli @@ -15,5 +15,4 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -val merge_into_exn : - (module Irmin.S with type t = 's) -> 's -> into:'s -> unit +val merge_into_exn : (module Irmin.S with type t = 's) -> 's -> into:'s -> unit diff --git a/test/irmin-containers/linked_log.ml b/test/irmin-containers/linked_log.ml index 0609c0dcc8..0f40c62044 100644 --- a/test/irmin-containers/linked_log.ml +++ b/test/irmin-containers/linked_log.ml @@ -42,7 +42,7 @@ let test_append_read_all () = L.append ~path t "main.2"; L.read_all ~path t |> Alcotest.(check (list string)) - "checked - log after appending" [ "main.2"; "main.1" ] + "checked - log after appending" [ "main.2"; "main.1" ] let test_read_incr () = let cur = config () |> L.Store.main |> L.get_cursor ~path in @@ -67,8 +67,8 @@ let test_clone_merge () = merge_into_exn b ~into:t; L.read_all ~path t |> Alcotest.(check (list string)) - "checked - log after appending" - [ "main.3"; "clone.1"; "main.2"; "main.1" ] + "checked - log after appending" + [ "main.3"; "clone.1"; "main.2"; "main.1" ] let test_branch_merge () = let r = config () in @@ -89,13 +89,13 @@ let test_branch_merge () = let () = L.read_all ~path b3 |> Alcotest.(check (list string)) - "checked - value of b3" - [ "b1.4"; "b2.2"; "b1.3"; "b1.2"; "b2.1"; "b1.1" ] + "checked - value of b3" + [ "b1.4"; "b2.2"; "b1.3"; "b1.2"; "b2.1"; "b1.1" ] in L.read_all ~path b4 |> Alcotest.(check (list string)) - "checked - value of b4" - [ "b1.4"; "b2.2"; "b1.3"; "b1.2"; "b2.1"; "b1.1" ] + "checked - value of b4" + [ "b1.4"; "b2.2"; "b1.3"; "b1.2"; "b2.1"; "b1.1" ] let test_cases = [ diff --git a/test/irmin-containers/lww_register.ml b/test/irmin-containers/lww_register.ml index 3010fcb8c1..22afc0e7cb 100644 --- a/test/irmin-containers/lww_register.ml +++ b/test/irmin-containers/lww_register.ml @@ -35,7 +35,7 @@ let test_empty_read () = |> L.Store.main |> L.read ~path |> Alcotest.(check (option int)) - "checked - reading register without writing" None + "checked - reading register without writing" None let test_write () = let t = config () |> L.Store.main in @@ -60,7 +60,7 @@ let test_clone_merge () = merge_into_exn b ~into:t; L.read ~path t |> Alcotest.(check (option int)) - "checked - value of main after merging" (Some 10) + "checked - value of main after merging" (Some 10) let test_branch_merge () = let r = config () in diff --git a/test/irmin-containers/test.ml b/test/irmin-containers/test.ml index 387715bd0e..4a15ee2bd3 100644 --- a/test/irmin-containers/test.ml +++ b/test/irmin-containers/test.ml @@ -18,7 +18,7 @@ let () = Eio_main.run @@ fun _env -> Alcotest.run "irmin-containers" - (Counter.test_cases - @ Lww_register.test_cases - @ Blob_log.test_cases - @ Linked_log.test_cases) + (Counter.test_cases + @ Lww_register.test_cases + @ Blob_log.test_cases + @ Linked_log.test_cases) diff --git a/test/irmin-fs/test.ml b/test/irmin-fs/test.ml index db06561af2..17fb69d99d 100644 --- a/test/irmin-fs/test.ml +++ b/test/irmin-fs/test.ml @@ -18,4 +18,4 @@ let () = Eio_main.run @@ fun env -> Irmin_fs.run env#fs @@ fun () -> Irmin_test.Store.run "irmin-fs" ~slow:true ~misc:[] ~sleep:Eio_unix.sleep - [ (`Quick, Test_fs.suite) ] + [ (`Quick, Test_fs.suite) ] diff --git a/test/irmin-fs/test_unix.ml b/test/irmin-fs/test_unix.ml index d73e7ee8b2..f312b9f3f4 100644 --- a/test/irmin-fs/test_unix.ml +++ b/test/irmin-fs/test_unix.ml @@ -19,5 +19,5 @@ let () = Irmin_fs.run env#fs @@ fun () -> Irmin_watcher.run @@ fun () -> Irmin_test.Store.run "irmin-fs.unix" ~slow:false ~sleep:Eio_unix.sleep - ~misc:[] - [ (`Quick, Test_fs_unix.suite) ] + ~misc:[] + [ (`Quick, Test_fs_unix.suite) ] diff --git a/test/irmin-mem/test.ml b/test/irmin-mem/test.ml index 03841d23ab..66298768f6 100644 --- a/test/irmin-mem/test.ml +++ b/test/irmin-mem/test.ml @@ -17,4 +17,4 @@ let () = Eio_main.run @@ fun _ -> Irmin_test.Store.run "irmin-mem" ~slow:true ~misc:[] ~sleep:Eio_unix.sleep - [ (`Quick, Test_mem.suite) ] + [ (`Quick, Test_mem.suite) ] diff --git a/test/irmin-pack/common.ml b/test/irmin-pack/common.ml index 534cee5628..07f497fd82 100644 --- a/test/irmin-pack/common.ml +++ b/test/irmin-pack/common.ml @@ -178,7 +178,7 @@ struct let close_pack t = Index.close_exn t.index; File_manager.close t.fm |> Errs.raise_if_error - (* closes pack and dict *) + (* closes pack and dict *) end module Alcotest = struct diff --git a/test/irmin-pack/common.mli b/test/irmin-pack/common.mli index 521d1e29fe..8c67ba3437 100644 --- a/test/irmin-pack/common.mli +++ b/test/irmin-pack/common.mli @@ -110,10 +110,10 @@ end) : sig dict : Dict.t; } - val get_rw_pack : unit -> t - val get_ro_pack : string -> t - val reopen_rw : string -> t - val close_pack : t -> unit + val get_rw_pack : unit -> t + val get_ro_pack : string -> t + val reopen_rw : string -> t + val close_pack : t -> unit end val get : 'a option -> 'a diff --git a/test/irmin-pack/test.ml b/test/irmin-pack/test.ml index dc08b5092b..32e5823b86 100644 --- a/test/irmin-pack/test.ml +++ b/test/irmin-pack/test.ml @@ -16,6 +16,5 @@ let () = Eio_main.run @@ fun _env -> - Irmin_test.Store.run "irmin-pack" ~misc:Test_pack.misc - ~sleep:Eio_unix.sleep - (List.map (fun s -> (`Quick, s)) Test_pack.suite) + Irmin_test.Store.run "irmin-pack" ~misc:Test_pack.misc ~sleep:Eio_unix.sleep + (List.map (fun s -> (`Quick, s)) Test_pack.suite) diff --git a/test/irmin-pack/test_corrupted.ml b/test/irmin-pack/test_corrupted.ml index faeb932016..9a2a47ebfb 100644 --- a/test/irmin-pack/test_corrupted.ml +++ b/test/irmin-pack/test_corrupted.ml @@ -69,8 +69,7 @@ let test_corrupted_control_file () = assert (not (String.equal control_file_blob1 control_file_mix)); write_file control_file_path control_file_mix; let error = - try Ok (Store.Repo.v (config ~fresh:false root)) - with exn -> Error exn + try Ok (Store.Repo.v (config ~fresh:false root)) with exn -> Error exn in (match error with | Error (Irmin_pack_unix.Errors.Pack_error (`Corrupted_control_file s)) -> @@ -80,5 +79,6 @@ let test_corrupted_control_file () = let tests = [ - Alcotest.test_case "Corrupted control file" `Quick test_corrupted_control_file; + Alcotest.test_case "Corrupted control file" `Quick + test_corrupted_control_file; ] diff --git a/test/irmin-pack/test_gc.ml b/test/irmin-pack/test_gc.ml index a5d7571efe..45f1e50770 100644 --- a/test/irmin-pack/test_gc.ml +++ b/test/irmin-pack/test_gc.ml @@ -233,9 +233,7 @@ let check_del_1 t c = let check_not_found t key msg = let c = S.Commit.of_hash t.repo (S.Commit.hash key) in - match c with - | None -> () - | Some _ -> Alcotest.failf "should not find %s" msg + match c with None -> () | Some _ -> Alcotest.failf "should not find %s" msg module type Gc_backend = sig val init : diff --git a/test/irmin-pack/test_gc.mli b/test/irmin-pack/test_gc.mli index dc32a48cc3..c063f240a4 100644 --- a/test/irmin-pack/test_gc.mli +++ b/test/irmin-pack/test_gc.mli @@ -44,8 +44,8 @@ module Store : sig val close : t -> unit val start_gc : ?unlink:bool -> t -> S.commit -> unit val finalise_gc : t -> unit - val commit_1 : t -> (t * S.commit) - val commit_2 : t -> (t * S.commit) - val commit_3 : t -> (t * S.commit) + val commit_1 : t -> t * S.commit + val commit_2 : t -> t * S.commit + val commit_3 : t -> t * S.commit val checkout_exn : t -> S.commit -> t end diff --git a/test/irmin-pack/test_inode.ml b/test/irmin-pack/test_inode.ml index 98a0b58dad..c0c918117b 100644 --- a/test/irmin-pack/test_inode.ml +++ b/test/irmin-pack/test_inode.ml @@ -156,9 +156,8 @@ struct [%log.app "Test context constructed"]; { store; store_contents; fm; foo; bar } - let close t = - File_manager.close t.fm |> Errs.raise_if_error - (* closes dict, inodes and contents store. *) + let close t = File_manager.close t.fm |> Errs.raise_if_error + (* closes dict, inodes and contents store. *) end module Context = Context_make (Inode) diff --git a/test/irmin-pack/test_nearest_leq.ml b/test/irmin-pack/test_nearest_leq.ml index 4d1cfe35b6..f69f6d1f4e 100644 --- a/test/irmin-pack/test_nearest_leq.ml +++ b/test/irmin-pack/test_nearest_leq.ml @@ -22,6 +22,5 @@ let test_nearest_leq () = let tests = [ - Alcotest.test_case "test_nearest_leq" `Quick (fun () -> - test_nearest_leq ()); + Alcotest.test_case "test_nearest_leq" `Quick (fun () -> test_nearest_leq ()); ] diff --git a/test/irmin-pack/test_pack.ml b/test/irmin-pack/test_pack.ml index 46e4e03034..00f8751433 100644 --- a/test/irmin-pack/test_pack.ml +++ b/test/irmin-pack/test_pack.ml @@ -215,7 +215,8 @@ module Pack = struct test t.pack; let t' = Context.get_ro_pack t.name in test t'.pack; - Context.close_pack t; Context.close_pack t' + Context.close_pack t; + Context.close_pack t' let test_readonly_pack () = let t = Context.get_rw_pack () in @@ -250,7 +251,8 @@ module Pack = struct let y3 = Pack.find t'.pack k3 in Alcotest.(check (option string)) "y3" (Some x3) y3 in - Context.close_pack t; Context.close_pack t' + Context.close_pack t; + Context.close_pack t' let test_close_pack_more () = (*open and close in rw*) @@ -275,7 +277,8 @@ module Pack = struct let t3 = Context.get_ro_pack t.name in let y1 = Pack.find t3.pack k1 |> get in Alcotest.(check string) "x1.3" x1 y1; - Context.close_pack t2; Context.close_pack t3 + Context.close_pack t2; + Context.close_pack t3 let test_close_pack () = let t = Context.get_rw_pack () in @@ -400,8 +403,10 @@ module Pack = struct Alcotest.test_case "RO pack" `Quick test_readonly_pack; Alcotest.test_case "close" `Quick test_close_pack; Alcotest.test_case "close readonly" `Quick test_close_pack_more; - Alcotest.test_case "readonly reload, index flush" `Quick readonly_reload_index_flush; - Alcotest.test_case "readonly find, index flush" `Quick readonly_find_index_flush; + Alcotest.test_case "readonly reload, index flush" `Quick + readonly_reload_index_flush; + Alcotest.test_case "readonly find, index flush" `Quick + readonly_find_index_flush; ] end diff --git a/test/irmin-pack/test_snapshot.ml b/test/irmin-pack/test_snapshot.ml index 407afe6bef..aa8a0f1bd5 100644 --- a/test/irmin-pack/test_snapshot.ml +++ b/test/irmin-pack/test_snapshot.ml @@ -240,9 +240,7 @@ let test_gced_store_on_disk () = let repo_import = S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_import) in - let () = - test_gc ~repo_export ~repo_import ~on_disk:(`Path index_on_disk) 5 - in + let () = test_gc ~repo_export ~repo_import ~on_disk:(`Path index_on_disk) 5 in let () = S.Repo.close repo_export in S.Repo.close repo_import diff --git a/test/irmin-pack/test_upgrade.ml b/test/irmin-pack/test_upgrade.ml index 99bc74ebde..c6b049b196 100644 --- a/test/irmin-pack/test_upgrade.ml +++ b/test/irmin-pack/test_upgrade.ml @@ -270,7 +270,7 @@ module Store = struct with Irmin_pack_unix.Pack_store.Invalid_read _ -> (* In RW mode, [mem] will raise an exception if the offset of the key is out of the bounds of the pack file *) - false + false let put_borphan bstore = let k = S.Backend.Contents.add bstore "borphan" in @@ -645,13 +645,13 @@ let test_one t ~ro_open_at ~ro_sync_at = let test_one_guarded setup ~ro_open_at ~ro_sync_at = let t = create_test_env setup in try - let () = test_one t ~ro_open_at ~ro_sync_at in - close_everything t + let () = test_one t ~ro_open_at ~ro_sync_at in + close_everything t with - | Skip_the_rest_of_that_test -> - [%logs.app "*** skip rest of %a" pp_setup setup]; - close_everything t - | exn -> raise exn + | Skip_the_rest_of_that_test -> + [%logs.app "*** skip rest of %a" pp_setup setup]; + close_everything t + | exn -> raise exn (** All possible interleaving of the ro calls (open and sync) with the rw calls (open, write1, gc and write2). *) diff --git a/test/irmin/generic-key/dune b/test/irmin/generic-key/dune index 9ddd2f5348..604c1d56fc 100644 --- a/test/irmin/generic-key/dune +++ b/test/irmin/generic-key/dune @@ -4,10 +4,4 @@ (package irmin-test) (preprocess (pps ppx_irmin.internal)) - (libraries - irmin - eio_main - irmin.mem - irmin-test - alcotest - vector)) + (libraries irmin eio_main irmin.mem irmin-test alcotest vector)) diff --git a/test/irmin/generic-key/test.ml b/test/irmin/generic-key/test.ml index 5f6c18447c..8bd7a49a17 100644 --- a/test/irmin/generic-key/test.ml +++ b/test/irmin/generic-key/test.ml @@ -17,6 +17,4 @@ let () = Eio_main.run @@ fun _env -> Irmin_test.Store.run __FILE__ ~slow:true ~misc:[] ~sleep:Eio_unix.sleep - [ - (`Quick, Test_store_offset.suite); (`Quick, Test_inlined_contents.suite); - ] + [ (`Quick, Test_store_offset.suite); (`Quick, Test_inlined_contents.suite) ] From a077d36d1c55fd6032ff1036baf9225759612cad Mon Sep 17 00:00:00 2001 From: ArthurW Date: Wed, 31 May 2023 19:22:51 +0200 Subject: [PATCH 15/99] Fix after rebase --- bench/irmin-pack/bench_common.mli | 6 +- examples/irmin-pack/gc.ml | 2 - examples/irmin-pack/kv.ml | 3 - irmin-fs.opam | 6 +- irmin-pack.opam | 10 +- irmin.opam | 6 + src/irmin-git/atomic_write.ml | 2 +- src/irmin-graphql/server.mli | 4 +- src/irmin-pack/unix/checks.ml | 71 +++---- src/irmin-pack/unix/gc.ml | 19 +- src/irmin-pack/unix/gc.mli | 3 +- src/irmin-pack/unix/import.ml | 11 ++ src/irmin-pack/unix/io.ml | 3 +- src/irmin-pack/unix/store.ml | 11 +- src/irmin-pack/unix/store_intf.ml | 3 +- src/irmin/content_addressable.ml | 18 +- src/irmin/store.ml | 24 +-- src/irmin/tree.ml | 4 +- test/irmin-pack/common.ml | 22 +-- test/irmin-pack/common.mli | 14 +- test/irmin-pack/test_async.ml | 16 +- test/irmin-pack/test_async.mli | 2 +- test/irmin-pack/test_corrupted.ml | 4 +- test/irmin-pack/test_existing_stores.ml | 38 ++-- test/irmin-pack/test_flush_reload.ml | 28 ++- test/irmin-pack/test_gc.ml | 153 ++++++++------- test/irmin-pack/test_gc.mli | 2 +- test/irmin-pack/test_indexing_strategy.ml | 32 ++- test/irmin-pack/test_indexing_strategy.mli | 2 +- test/irmin-pack/test_inode.ml | 16 +- test/irmin-pack/test_lower.ml | 218 ++++++++++----------- test/irmin-pack/test_lower.mli | 4 +- test/irmin-pack/test_mapping.ml | 8 +- test/irmin-pack/test_nearest_geq.ml | 8 +- test/irmin-pack/test_pack.ml | 12 +- test/irmin-pack/test_ranges.ml | 6 +- test/irmin-pack/test_snapshot.ml | 28 +-- test/irmin-tezos/dune | 2 +- test/irmin-tezos/generate.ml | 48 +++-- test/irmin/test_conf.ml | 5 +- test/irmin/test_tree.ml | 19 +- 41 files changed, 444 insertions(+), 449 deletions(-) diff --git a/bench/irmin-pack/bench_common.mli b/bench/irmin-pack/bench_common.mli index 9f2cf0335b..60bf61224e 100644 --- a/bench/irmin-pack/bench_common.mli +++ b/bench/irmin-pack/bench_common.mli @@ -19,7 +19,7 @@ val prepare_artefacts_dir : string -> unit val reporter : ?prefix:string -> unit -> Logs.reporter val setup_log : Fmt.style_renderer option -> Logs.level option -> unit val reset_stats : unit -> unit -val with_timer : (unit -> 'a Lwt.t) -> (float * 'a) Lwt.t +val with_timer : (unit -> 'a) -> float * 'a val with_progress_bar : message:string -> n:int -> unit:string -> ((int -> unit) -> 'a) -> 'a @@ -40,11 +40,11 @@ end module Generate_trees (Store : Irmin.Generic_key.KV with type Schema.Contents.t = bytes) : sig - val add_chain_trees : int -> int -> Store.tree -> Store.tree Lwt.t + val add_chain_trees : int -> int -> Store.tree -> Store.tree (** [add_chain_trees depth nb tree] adds [nb] random contents to [tree], depthwise. *) - val add_large_trees : int -> int -> Store.tree -> Store.tree Lwt.t + val add_large_trees : int -> int -> Store.tree -> Store.tree (** [add_large_trees width nb tree] adds [nb] random contents to [tree], breadthwise. *) end diff --git a/examples/irmin-pack/gc.ml b/examples/irmin-pack/gc.ml index b22a20f2e1..c6282f5a49 100644 --- a/examples/irmin-pack/gc.ml +++ b/examples/irmin-pack/gc.ml @@ -14,8 +14,6 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Lwt.Syntax - module Schema = Irmin.Schema.KV (Irmin.Contents.String) (** Make schema *) diff --git a/examples/irmin-pack/kv.ml b/examples/irmin-pack/kv.ml index 7183028acf..418594fdae 100644 --- a/examples/irmin-pack/kv.ml +++ b/examples/irmin-pack/kv.ml @@ -16,9 +16,6 @@ (* A minimal example of instantiating a `irmin-pack.unix` key-value store. *) -open Lwt -open Lwt.Syntax - let src = Logs.Src.create "irmin-pack.unix/examples/kv" ~doc:"irmin-pack.unix/examples/kv" diff --git a/irmin-fs.opam b/irmin-fs.opam index e88d8f9070..b31298375d 100644 --- a/irmin-fs.opam +++ b/irmin-fs.opam @@ -22,7 +22,11 @@ depends: [ "lwt" {>= "5.3.0"} "alcotest" {with-test} "irmin-test" {with-test & = version} - "irmin-watcher" {with-test & >= "0.2.0"} + "irmin-watcher" {with-test & = "dev"} +] + +pin-depends: [ + [ "irmin-watcher.dev" "git+https://github.com/patricoferris/irmin-watcher#d0e92b4ba5631b5f4dc0f3c00d97e79542dba45d" ] ] synopsis: "Generic file-system backend for Irmin" diff --git a/irmin-pack.opam b/irmin-pack.opam index ed7460fde9..a0d7af51b8 100644 --- a/irmin-pack.opam +++ b/irmin-pack.opam @@ -17,7 +17,7 @@ depends: [ "dune" {>= "2.9.0"} "irmin" {= version} "ppx_irmin" {= version} - "index" {>= "1.6.0"} + "index" {= "dev"} "fmt" "logs" "lwt" {>= "5.4.0"} @@ -32,4 +32,12 @@ depends: [ "alcotest" {with-test} ] +pin-depends: [ + # Needed by Index + [ "terminal.dev" "git+https://github.com/craigfe/progress#76e7c791bd17c28b3e605d9c383102a30345e029" ] + [ "progress.dev" "git+https://github.com/craigfe/progress#76e7c791bd17c28b3e605d9c383102a30345e029" ] + # Needed by Irmin-pack + [ "index.dev" "git+https://github.com/patricoferris/index#cfa32e984b633d08b2f0c1fc1f792925c6d74f8e" ] +] + synopsis: "Irmin backend which stores values in a pack file" diff --git a/irmin.opam b/irmin.opam index a6e5732f86..334eaf19c2 100644 --- a/irmin.opam +++ b/irmin.opam @@ -40,6 +40,12 @@ depends: [ "bisect_ppx" {dev & >= "2.5.0"} ] +pin-depends: [ + # Metrics may have been unnecessarily constrained in opam-repository + [ "metrics.dev" "git+https://github.com/mirage/metrics#995eb18d2837df02c8ead719c00fb156cf475ab5"] + [ "metrics-unix.dev" "git+https://github.com/mirage/metrics#995eb18d2837df02c8ead719c00fb156cf475ab5"] +] + conflicts: [ "result" {< "1.5"} # Requires `Result = Stdlib.Result` ] diff --git a/src/irmin-git/atomic_write.ml b/src/irmin-git/atomic_write.ml index 58ea59963f..ce50c1b7c0 100644 --- a/src/irmin-git/atomic_write.ml +++ b/src/irmin-git/atomic_write.ml @@ -65,7 +65,7 @@ module Check_closed (S : Irmin.Atomic_write.S) = struct let v t = { closed = ref false; t } let close t = - if !(t.closed) then Lwt.return_unit + if !(t.closed) then () else ( t.closed := true; S.close t.t) diff --git a/src/irmin-graphql/server.mli b/src/irmin-graphql/server.mli index 84a778fa65..a249bac40c 100644 --- a/src/irmin-graphql/server.mli +++ b/src/irmin-graphql/server.mli @@ -31,8 +31,8 @@ module type S = sig val execute_request : unit Schema.schema -> - Cohttp_lwt.Request.t -> - Cohttp_lwt.Body.t -> + Cohttp.Request.t -> + Cohttp.Body.t -> response_action Lwt.t val v : repo -> server diff --git a/src/irmin-pack/unix/checks.ml b/src/irmin-pack/unix/checks.ml index 5a923a09c2..08ca88d0b2 100644 --- a/src/irmin-pack/unix/checks.ml +++ b/src/irmin-pack/unix/checks.ml @@ -244,8 +244,7 @@ module Make (Store : Store) = struct let term_internal = Cmdliner.Term.( const (fun root auto_repair always heads () -> - run ~ppf:Format.err_formatter ~root ~auto_repair ~always ~heads - ()) + run ~ppf:Format.err_formatter ~root ~auto_repair ~always ~heads ()) $ path $ auto_repair $ always @@ -467,17 +466,13 @@ struct (* TODO: The goal here is to check a "one commit" store, generated by a gc, in which indexed keys cannot occur. We might want to extends this to stores that have both indexed and direct keys. *) - Lwt.fail_with + failwith "Not supported for stores which have entries obtained with irmin < \ 3.0. If all entries were added with irmin < 3.0, please use \ [integrity_check] instead." | Direct { offset; length; hash; _ } -> ( let result = check ~offset ~length hash in - match result with - | Ok () -> Lwt.return_unit - | Error err -> - add_error err hash; - Lwt.return_unit) + match result with Ok () -> () | Error err -> add_error err hash) in (* Commits are read from disk and checked by the [find] function in [pred]. We need to explicitly check the contents and the nodes. *) @@ -486,27 +481,25 @@ struct check_contents key in let pred_node repo key = - try - X.Node.find (X.Repo.node_t repo) key >|= function - | None -> - Fmt.failwith "node with hash %a not found" pp_hash - (XKey.to_hash key) - | Some v -> - let preds = pred v in - List.rev_map - (function - | s, `Inode x -> - assert (s = None); - `Node x - | _, `Node x -> `Node x - | _, `Contents x -> `Contents x) - preds - with _exn -> - add_error `Wrong_hash (XKey.to_hash key); - Lwt.return [] + match X.Node.find (X.Repo.node_t repo) key with + | None -> + Fmt.failwith "node with hash %a not found" pp_hash (XKey.to_hash key) + | Some v -> + let preds = pred v in + List.rev_map + (function + | s, `Inode x -> + assert (s = None); + `Node x + | _, `Node x -> `Node x + | _, `Contents x -> `Contents x) + preds + | exception _exn -> + add_error `Wrong_hash (XKey.to_hash key); + [] in let check_nodes key = - X.Node.find (X.Repo.node_t t) key >|= function + match X.Node.find (X.Repo.node_t t) key with | None -> Fmt.failwith "node with hash %a not found" pp_hash (XKey.to_hash key) | Some v -> @@ -522,17 +515,17 @@ struct let pred_commit repo k = try progress_commits (); - X.Commit.find (X.Repo.commit_t repo) k >|= function + match X.Commit.find (X.Repo.commit_t repo) k with | None -> [] | Some c -> let node = X.Commit.Val.node c in [ `Node node ] with _exn -> add_error `Wrong_hash (XKey.to_hash k); - Lwt.return [] + [] in - let+ () = iter ~contents ~node ~pred_node ~pred_commit t in + let () = iter ~contents ~node ~pred_node ~pred_commit t in Utils.Object_counter.finalise counter; if !errors = [] then Ok `No_error else @@ -550,21 +543,17 @@ struct in let errors = ref [] in let pred_node repo key = - Lwt.catch - (fun () -> pred repo key) - (fun _ -> - errors := "Error in repo iter" :: !errors; - Lwt.return []) + try pred repo key + with _ -> + errors := "Error in repo iter" :: !errors; + [] in let node k = progress_nodes (); - check k >|= function Ok () -> () | Error msg -> errors := msg :: !errors - in - let commit _ = - progress_commits (); - Lwt.return_unit + match check k with Ok () -> () | Error msg -> errors := msg :: !errors in - let+ () = iter ~pred_node ~node ~commit t in + let commit _ = progress_commits () in + let () = iter ~pred_node ~node ~commit t in Utils.Object_counter.finalise counter; if !errors = [] then Ok `No_error else diff --git a/src/irmin-pack/unix/gc.ml b/src/irmin-pack/unix/gc.ml index 944fa649a4..afda2baf40 100644 --- a/src/irmin-pack/unix/gc.ml +++ b/src/irmin-pack/unix/gc.ml @@ -312,16 +312,15 @@ module Make (Args : Gc_args.S) = struct let gc_output = read_gc_output ~root:t.root ~generation:t.generation in match (status, gc_output) with | `Success, Ok gc_results -> - { - Control_file_intf.Payload.Upper.Latest.generation = - Fm.generation t.fm + 1; - latest_gc_target_offset = t.latest_gc_target_offset; - suffix_start_offset = t.new_suffix_start_offset; - suffix_dead_bytes = Int63.zero; - mapping_end_poff = Some gc_results.mapping_size; - } - | _ -> - gc_errors status gc_output |> Errs.raise_if_error + { + Control_file_intf.Payload.Upper.Latest.generation = + Fm.generation t.fm + 1; + latest_gc_target_offset = t.latest_gc_target_offset; + suffix_start_offset = t.new_suffix_start_offset; + suffix_dead_bytes = Int63.zero; + mapping_end_poff = Some gc_results.mapping_size; + } + | _ -> gc_errors status gc_output |> Errs.raise_if_error let on_finalise t f = (* Ignore returned promise since the purpose of this diff --git a/src/irmin-pack/unix/gc.mli b/src/irmin-pack/unix/gc.mli index 0537656daf..5340b1268f 100644 --- a/src/irmin-pack/unix/gc.mli +++ b/src/irmin-pack/unix/gc.mli @@ -54,8 +54,7 @@ module Make val cancel : t -> bool - val finalise_without_swap : - t -> Control_file_intf.Payload.Upper.Latest.gced + val finalise_without_swap : t -> Control_file_intf.Payload.Upper.Latest.gced (** Waits for the current gc to finish and returns immediately without swapping the files and doing the other finalisation steps from [finalise]. Returns the [gced] status to create a fresh control file for the snapshot. *) diff --git a/src/irmin-pack/unix/import.ml b/src/irmin-pack/unix/import.ml index ed3b6bf420..11dad9a56f 100644 --- a/src/irmin-pack/unix/import.ml +++ b/src/irmin-pack/unix/import.ml @@ -83,3 +83,14 @@ module Varint = struct [63 / 7] equals [9]. *) let max_encoded_size = 9 end + +module Mtime = struct + include Mtime + + module Span = struct + include Mtime.Span + + let to_s span = Mtime.Span.to_float_ns span *. 1e-9 + let to_us span = Mtime.Span.to_float_ns span *. 1e-3 + end +end diff --git a/src/irmin-pack/unix/io.ml b/src/irmin-pack/unix/io.ml index 5bf022d1e9..971aec480f 100644 --- a/src/irmin-pack/unix/io.ml +++ b/src/irmin-pack/unix/io.ml @@ -294,5 +294,6 @@ module Unix = struct with Sys_error msg -> Error (`Sys_error msg) let unlink_dont_wait ~on_exn path = - Lwt.dont_wait (fun () -> Lwt_unix.unlink path) on_exn + (* TODO: Lwt.dont_wait (fun () -> Lwt_unix.unlink path) on_exn *) + try Sys.remove path with err -> on_exn err end diff --git a/src/irmin-pack/unix/store.ml b/src/irmin-pack/unix/store.ml index 2cdb193e03..73dfe9f4d9 100644 --- a/src/irmin-pack/unix/store.ml +++ b/src/irmin-pack/unix/store.ml @@ -460,9 +460,7 @@ module Maker (Config : Conf.S) = struct module Integrity_checks = Checks.Integrity_checks (XKey) (X) (Index) let integrity_check_inodes ?heads t = - let* heads = - match heads with None -> Repo.heads t | Some m -> Lwt.return m - in + let heads = match heads with None -> Repo.heads t | Some m -> m in let hashes = List.map (fun x -> `Commit (Commit.key x)) heads in let iter ~pred_node ~node ~commit t = Repo.iter ~cache_size:1_000_000 ~min:[] ~max:hashes ~pred_node ~node @@ -507,11 +505,8 @@ module Maker (Config : Conf.S) = struct |> Conf.indexing_strategy |> Irmin_pack.Indexing_strategy.is_minimal in - let result = - if is_minimal then integrity_check_minimal ?ppf ?heads t - else integrity_check_always ?ppf ~auto_repair t |> Lwt.return - in - result + if is_minimal then integrity_check_minimal ?ppf ?heads t + else integrity_check_always ?ppf ~auto_repair t module Stats_computation = struct let pp_key = Irmin.Type.pp XKey.t diff --git a/src/irmin-pack/unix/store_intf.ml b/src/irmin-pack/unix/store_intf.ml index 70ca9230fc..754cebc92a 100644 --- a/src/irmin-pack/unix/store_intf.ml +++ b/src/irmin-pack/unix/store_intf.ml @@ -285,8 +285,7 @@ module type S = sig (** {1 Statistics} *) - val stats : - dump_blob_paths_to:string option -> commit:commit -> repo -> unit + val stats : dump_blob_paths_to:string option -> commit:commit -> repo -> unit (** {1 Internals} *) diff --git a/src/irmin/content_addressable.ml b/src/irmin/content_addressable.ml index c4616a40fb..b9bfd39c1c 100644 --- a/src/irmin/content_addressable.ml +++ b/src/irmin/content_addressable.ml @@ -35,7 +35,23 @@ module Make (AO : Append_only.Maker) (K : Hash.S) (V : Type.S) = struct Fmt.kstr invalid_arg "corrupted value: got %a, expecting %a" pp_key k' pp_key k - let unsafe_add t k v = add t k v + let add t v = + check_not_closed t; + S.add t.t v + + let unsafe_add t k v = + check_not_closed t; + S.unsafe_add t.t k v + + let v ?ctx uri item items = + let t = S.v ?ctx uri item items in + { closed = ref false; t } + + let close t = + if !(t.closed) then Lwt.return_unit + else ( + t.closed := true; + S.close t.t) let add t v = let k = hash v in diff --git a/src/irmin/store.ml b/src/irmin/store.ml index 522eb29364..75cfcf0f3f 100644 --- a/src/irmin/store.ml +++ b/src/irmin/store.ml @@ -834,9 +834,10 @@ module Make (B : Backend.S) = struct update t k ?clear ?allow_empty ?parents ~info (test_and_set_tree_once ~test) @@ fun _tree -> set - let test_set_and_get_tree_exn ?clear ?retries ?allow_empty ?parents ~info t k ~test - ~set = - test_set_and_get_tree ?clear ?retries ?allow_empty ?parents ~info t k ~test ~set + let test_set_and_get_tree_exn ?clear ?retries ?allow_empty ?parents ~info t k + ~test ~set = + test_set_and_get_tree ?clear ?retries ?allow_empty ?parents ~info t k ~test + ~set |> fail "test_set_and_get_tree_exn" let test_set_and_get ?clear ?retries ?allow_empty ?parents ~info t k ~test @@ -846,7 +847,8 @@ module Make (B : Backend.S) = struct test_set_and_get_tree ?clear ?retries ?allow_empty ?parents ~info t k ~test ~set - let test_set_and_get_exn ?clear ?retries ?allow_empty ?parents ~info t k ~test ~set = + let test_set_and_get_exn ?clear ?retries ?allow_empty ?parents ~info t k ~test + ~set = test_set_and_get ?clear ?retries ?allow_empty ?parents ~info t k ~test ~set |> fail "test_set_and_get_exn" @@ -857,8 +859,8 @@ module Make (B : Backend.S) = struct @@ test_set_and_get_tree ~retries ?clear ?allow_empty ?parents ~info t k ~test ~set - let test_and_set_tree_exn ?clear ?retries ?allow_empty ?parents ~info t k ~test ~set - = + let test_and_set_tree_exn ?clear ?retries ?allow_empty ?parents ~info t k + ~test ~set = test_and_set_tree ?clear ?retries ?allow_empty ?parents ~info t k ~test ~set |> fail "test_and_set_tree_exn" @@ -885,7 +887,7 @@ module Make (B : Backend.S) = struct @@ retry ~retries @@ fun () -> update t k ?clear ?allow_empty ?parents ~info (merge_once ~old) - @@ fun _tree -> Lwt.return tree + @@ fun _tree -> tree let merge_tree_exn ?clear ?retries ?allow_empty ?parents ~info ~old t k tree = merge_tree ?clear ?retries ?allow_empty ?parents ~info ~old t k tree @@ -938,8 +940,8 @@ module Make (B : Backend.S) = struct | `Set, None -> remove ?clear t key ~retries ?allow_empty ~info ?parents | `Test_and_set, _ -> ( match - test_and_set_tree ?clear t key ~retries ?allow_empty ?parents ~info - ~test:old_tree ~set:new_tree + test_and_set_tree ?clear t key ~retries ?allow_empty ?parents + ~info ~test:old_tree ~set:new_tree with | Error (`Test_was tr) when retries > 0 && n <= retries -> done_once := true; @@ -947,8 +949,8 @@ module Make (B : Backend.S) = struct | e -> e) | `Merge, _ -> ( match - merge_tree ?clear ~old:old_tree ~retries ?allow_empty ?parents ~info t - key new_tree + merge_tree ?clear ~old:old_tree ~retries ?allow_empty ?parents + ~info t key new_tree with | Ok _ as x -> x | Error (`Conflict _) when retries > 0 && n <= retries -> diff --git a/src/irmin/tree.ml b/src/irmin/tree.ml index d8276638c5..8b3fa3278e 100644 --- a/src/irmin/tree.ml +++ b/src/irmin/tree.ml @@ -1155,9 +1155,9 @@ module Make (P : Backend.S) = struct let length ~cache t = match t.info.length with - | Some (lazy len) -> Lwt.return len + | Some (lazy len) -> len | None -> - let+ len = slow_length ~cache t in + let len = slow_length ~cache t in t.info.length <- Some (Lazy.from_val len); len diff --git a/test/irmin-pack/common.ml b/test/irmin-pack/common.ml index 07f497fd82..6e051d1339 100644 --- a/test/irmin-pack/common.ml +++ b/test/irmin-pack/common.ml @@ -187,19 +187,20 @@ module Alcotest = struct let int63 = testable Int63.pp Int63.equal let check_raises_pack_error msg pass f = - Lwt.try_bind f - (fun _ -> + match f () with + | _ -> Alcotest.failf - "Fail %s: expected function to raise, but it returned instead." msg) - (function - | Irmin_pack_unix.Errors.Pack_error e as exn -> ( + "Fail %s: expected function to raise, but it returned instead." msg + | exception exn -> ( + match exn with + | Irmin_pack_unix.Errors.Pack_error e -> ( match pass e with - | true -> Lwt.return_unit + | true -> () | false -> Alcotest.failf "Fail %s: function raised unexpected exception %s" msg (Printexc.to_string exn)) - | exn -> + | _ -> Alcotest.failf "Fail %s: expected function to raise Pack_error, but it raised \ %s instead" @@ -225,12 +226,7 @@ module Alcotest = struct let check_repr ?pos t = Alcotest.check ?pos (testable_repr t) let kind = testable_repr Irmin_pack.Pack_value.Kind.t let hash = testable_repr Schema.Hash.t -end - -module Alcotest_lwt = struct - include Alcotest_lwt - - let quick_tc name f = test_case name `Quick (fun _switch () -> f ()) + let quick_tc name f = test_case name `Quick f end module Filename = struct diff --git a/test/irmin-pack/common.mli b/test/irmin-pack/common.mli index 8c67ba3437..f05fc317fc 100644 --- a/test/irmin-pack/common.mli +++ b/test/irmin-pack/common.mli @@ -55,10 +55,7 @@ module Alcotest : sig val hash : Schema.Hash.t testable val check_raises_pack_error : - string -> - (Irmin_pack_unix.Errors.base_error -> bool) -> - (unit -> _) -> - unit + string -> (Irmin_pack_unix.Errors.base_error -> bool) -> (unit -> _) -> unit val check_raises : string -> exn -> (unit -> _) -> unit @@ -71,14 +68,9 @@ module Alcotest : sig unit val testable_repr : 'a Irmin.Type.t -> 'a Alcotest.testable -end - -module Alcotest_lwt : sig - include module type of Alcotest_lwt - val quick_tc : string -> (unit -> unit Lwt.t) -> unit test_case - (** Convenience to create a `Quick test_case that doesn't need to use a - switch. *) + val quick_tc : string -> (unit -> unit) -> unit test_case + (** Convenience to create a `Quick test_case *) end module Index : module type of Irmin_pack_unix.Index.Make (Schema.Hash) diff --git a/test/irmin-pack/test_async.ml b/test/irmin-pack/test_async.ml index 94b3becc99..32f24e2fc6 100644 --- a/test/irmin-pack/test_async.ml +++ b/test/irmin-pack/test_async.ml @@ -23,21 +23,17 @@ let check_outcome = Alcotest.check_repr Async.outcome_t let test_success () = let f () = assert true in let task = Async.async f in - let* result = Async.await task in - check_outcome "should succeed" result `Success; - Lwt.return_unit + let result = Async.await task in + check_outcome "should succeed" result `Success let test_exception_in_task () = let f () = assert false in let task = Async.async f in - let* result = Async.await task in - check_outcome "should fail" result (`Failure "Unhandled exception"); - Lwt.return_unit + let result = Async.await task in + check_outcome "should fail" result (`Failure "Unhandled exception") let tests = [ - Alcotest_lwt.test_case "Successful task" `Quick (fun _switch -> - test_success); - Alcotest_lwt.test_case "Exception occurs in task" `Quick (fun _switch -> - test_exception_in_task); + Alcotest.test_case "Successful task" `Quick test_success; + Alcotest.test_case "Exception occurs in task" `Quick test_exception_in_task; ] diff --git a/test/irmin-pack/test_async.mli b/test/irmin-pack/test_async.mli index 8bfc894f64..57112a0179 100644 --- a/test/irmin-pack/test_async.mli +++ b/test/irmin-pack/test_async.mli @@ -14,4 +14,4 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -val tests : unit Alcotest_lwt.test_case list +val tests : unit Alcotest.test_case list diff --git a/test/irmin-pack/test_corrupted.ml b/test/irmin-pack/test_corrupted.ml index 9a2a47ebfb..76b3272e04 100644 --- a/test/irmin-pack/test_corrupted.ml +++ b/test/irmin-pack/test_corrupted.ml @@ -71,11 +71,11 @@ let test_corrupted_control_file () = let error = try Ok (Store.Repo.v (config ~fresh:false root)) with exn -> Error exn in - (match error with + match error with | Error (Irmin_pack_unix.Errors.Pack_error (`Corrupted_control_file s)) -> Alcotest.(check string) "path is corrupted" s "_build/test-corrupted/store.control" - | _ -> Alcotest.fail "unexpected error") + | _ -> Alcotest.fail "unexpected error" let tests = [ diff --git a/test/irmin-pack/test_existing_stores.ml b/test/irmin-pack/test_existing_stores.ml index 9e7784f251..c8418c4317 100644 --- a/test/irmin-pack/test_existing_stores.ml +++ b/test/irmin-pack/test_existing_stores.ml @@ -183,16 +183,16 @@ module Test_corrupted_stores = struct let rw = S.Repo.v (config ~fresh:false root) in [%log.app "integrity check on a store where 3 entries are missing from pack"]; - let* result = S.integrity_check ~auto_repair:false rw in + let result = S.integrity_check ~auto_repair:false rw in (match result with | Ok `No_error -> Alcotest.fail "Store is corrupted, the check should fail" | Error (`Corrupted 3) -> () | _ -> Alcotest.fail "With auto_repair:false should not match"); - let* result = S.integrity_check ~auto_repair:true rw in + let result = S.integrity_check ~auto_repair:true rw in (match result with | Ok (`Fixed 3) -> () | _ -> Alcotest.fail "Integrity check should repair the store"); - let* result = S.integrity_check ~auto_repair:false rw in + let result = S.integrity_check ~auto_repair:false rw in (match result with | Ok `No_error -> () | _ -> Alcotest.fail "Store is repaired, should return Ok"); @@ -228,23 +228,23 @@ module Test_corrupted_stores = struct config ~fresh:false ~indexing_strategy:Irmin_pack.Indexing_strategy.minimal root_local_build in - let* rw = S.Repo.v config in + let rw = S.Repo.v config in - let* commit = + let commit = commit_of_string rw "22e159de13b427226e5901defd17f0c14e744205" in - let* result = S.integrity_check ~heads:[ commit ] ~auto_repair:false rw in + let result = S.integrity_check ~heads:[ commit ] ~auto_repair:false rw in let () = match result with | Ok `No_error -> () | Error (`Cannot_fix err) -> Alcotest.failf "Store is corrupted %s" err | _ -> Alcotest.fail "Unexpected result of integrity_check" in - let* () = S.Repo.close rw in + let () = S.Repo.close rw in [%log.app "integrity check on a corrupted minimal store"]; write_corrupted_data_to_suffix (); - let* rw = S.Repo.v config in - let* result = S.integrity_check ~heads:[ commit ] ~auto_repair:false rw in + let rw = S.Repo.v config in + let result = S.integrity_check ~heads:[ commit ] ~auto_repair:false rw in let () = match result with | Ok `No_error -> Alcotest.fail "Store is corrupted, check should fail" @@ -255,8 +255,7 @@ module Test_corrupted_stores = struct | _ -> Alcotest.fail "Unexpected result of integrity_check" in - let* () = S.Repo.close rw in - Lwt.return_unit + S.Repo.close rw end module Test_corrupted_inode = struct @@ -336,16 +335,15 @@ end let tests = [ - Alcotest.test_case "Test index reconstruction" `Quick (fun _switch -> - Test_reconstruct.test_reconstruct); - Alcotest.test_case "Test gc not allowed" `Quick (fun _switch -> - Test_reconstruct.test_gc_allowed); - Alcotest.test_case "Test integrity check" `Quick (fun _switch -> - Test_corrupted_stores.test); + Alcotest.test_case "Test index reconstruction" `Quick + Test_reconstruct.test_reconstruct; + Alcotest.test_case "Test gc not allowed" `Quick + Test_reconstruct.test_gc_allowed; + Alcotest.test_case "Test integrity check" `Quick Test_corrupted_stores.test; Alcotest.test_case "Test integrity check minimal stores" `Quick - (fun _switch -> Test_corrupted_stores.test_minimal); + Test_corrupted_stores.test_minimal; Alcotest.test_case "Test integrity check for inodes" `Quick - (fun _switch -> Test_corrupted_inode.test); + Test_corrupted_inode.test; Alcotest.test_case "Test traverse pack on gced store" `Quick - (fun _switch -> Test_traverse_gced.test_traverse_pack); + Test_traverse_gced.test_traverse_pack; ] diff --git a/test/irmin-pack/test_flush_reload.ml b/test/irmin-pack/test_flush_reload.ml index e615d265be..345b67c1b0 100644 --- a/test/irmin-pack/test_flush_reload.ml +++ b/test/irmin-pack/test_flush_reload.ml @@ -117,19 +117,18 @@ let test_one t ~(ro_reload_at : phase_flush) = check_ro t in let rw, _ = start t in - Store.S.Backend.Repo.batch rw (fun bstore nstore cstore -> - let* () = write1_no_flush bstore nstore cstore in - let () = aux S1_before_flush in - let hook = function - | `After_dict -> aux S2_after_flush_dict - | `After_suffix -> aux S3_after_flush_suffix - in - let () = - Store.S.Internal.( - File_manager.flush ~hook (file_manager rw) |> Errs.raise_if_error) - in - aux S4_after_flush - ) + Store.S.Backend.Repo.batch rw (fun bstore nstore cstore -> + let () = write1_no_flush bstore nstore cstore in + let () = aux S1_before_flush in + let hook = function + | `After_dict -> aux S2_after_flush_dict + | `After_suffix -> aux S3_after_flush_suffix + in + let () = + Store.S.Internal.( + File_manager.flush ~hook (file_manager rw) |> Errs.raise_if_error) + in + aux S4_after_flush) let test_one_guarded setup ~ro_reload_at = let t = create_test_env setup in @@ -208,8 +207,7 @@ let test_one t ~(rw_flush_at : phase_reload) = Store.S.Internal.( File_manager.reload ~hook (file_manager ro) |> Errs.raise_if_error) in - aux S5_after_reload - ) + aux S5_after_reload) in let () = check_ro t in let () = reload_ro () in diff --git a/test/irmin-pack/test_gc.ml b/test/irmin-pack/test_gc.ml index 45f1e50770..4de4b71774 100644 --- a/test/irmin-pack/test_gc.ml +++ b/test/irmin-pack/test_gc.ml @@ -155,6 +155,21 @@ module Store = struct let h = commit t in (t, h) + let commit_4 t = + let t = set t [ "a"; "e" ] "Mars" in + let h = commit t in + (t, h) + + let commit_5 t = + let t = set t [ "e"; "a" ] "Avril" in + let h = commit t in + (t, h) + + let commit_del t = + let t = del t [ "a"; "c" ] in + let h = commit t in + (t, h) + let commit_1_different_author t = let info = S.Info.v ~author:"someone" Int64.zero in let t = set t [ "a"; "b" ] "Novembre" in @@ -237,15 +252,10 @@ let check_not_found t key msg = module type Gc_backend = sig val init : - ?lru_size:int -> - ?readonly:bool -> - ?fresh:bool -> - ?root:string -> - unit -> - t Lwt.t - - val check_gced : t -> S.commit -> string -> unit Lwt.t - val check_removed : t -> S.commit -> string -> unit Lwt.t + ?lru_size:int -> ?readonly:bool -> ?fresh:bool -> ?root:string -> unit -> t + + val check_gced : t -> S.commit -> string -> unit + val check_removed : t -> S.commit -> string -> unit end let rec check_async_unlinked ?(timeout = 3.141) file = @@ -555,7 +565,7 @@ module Gc_common (B : Gc_backend) = struct let t = B.init () in let t, c1 = commit_1 t in let _ = - Alcotest.check_raises_lwt "Should not call gc in batch" + Alcotest.check_raises "Should not call gc in batch" (Irmin_pack_unix.Errors.Pack_error `Gc_forbidden_during_batch) (fun () -> S.Backend.Repo.batch t.repo (fun _ _ _ -> @@ -668,22 +678,22 @@ module Gc_common (B : Gc_backend) = struct (** Check that a GC clears the LRU *) let gc_clears_lru () = - let* t = init ~lru_size:100 () in + let t = init ~lru_size:100 () in (* Rreate some commits *) - let* t, c1 = commit_1 t in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in - let* t = checkout_exn t c2 in - let* t, c3 = commit_3 t in + let t, c1 = commit_1 t in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in + let t = checkout_exn t c2 in + let t, c3 = commit_3 t in (* Read some data *) - let* () = check_2 t c2 in - let* () = check_3 t c3 in + let () = check_2 t c2 in + let () = check_3 t c3 in (* GC *) let count_before_gc = lru_hits () in - let* () = start_gc t c2 in - let* () = finalise_gc t in + let () = start_gc t c2 in + let () = finalise_gc t in (* Read data again *) - let* () = check_3 t c3 in + let () = check_3 t c3 in Alcotest.(check int) "GC does clear LRU" count_before_gc (lru_hits ()); S.Repo.close t.repo @@ -727,15 +737,15 @@ module Gc_archival = struct let gc_availability_recent () = let lower_root = create_lower_root ~mkdir:false () in - let* t = init ~lower_root:(Some lower_root) () in + let t = init ~lower_root:(Some lower_root) () in Alcotest.(check gc_behaviour) "recent stores with a lower use archiving gc" (S.Gc.behaviour t.repo) `Archive; Alcotest.(check bool) "archiving gc allowed on recent stores with a lower" (S.Gc.is_allowed t.repo) true; - let* () = S.Repo.close t.repo in - let* t = init () in + let () = S.Repo.close t.repo in + let t = init () in Alcotest.(check gc_behaviour) "recent stores without a lower use deleting gc" (S.Gc.behaviour t.repo) `Delete; @@ -747,16 +757,16 @@ module Gc_archival = struct let gc_availability_old () = let root = create_v1_test_env () in let lower_root = create_lower_root () in - let* t = init ~root ~fresh:false ~lower_root:(Some lower_root) () in + let t = init ~root ~fresh:false ~lower_root:(Some lower_root) () in Alcotest.(check gc_behaviour) "old stores with a lower use archiving gc" (S.Gc.behaviour t.repo) `Archive; Alcotest.(check bool) "archiving gc allowed on old stores with a lower" (S.Gc.is_allowed t.repo) true; - let* () = S.Repo.close t.repo in + let () = S.Repo.close t.repo in let root = create_v1_test_env () in - let* t = init ~root ~fresh:false () in + let t = init ~root ~fresh:false () in Alcotest.(check gc_behaviour) "old stores without a lower use deleting gc" (S.Gc.behaviour t.repo) `Delete; @@ -769,10 +779,10 @@ module Gc_archival = struct let root = create_v1_test_env () in let lower_root = create_lower_root () in [%log.debug "Open v1 store to trigger migration"]; - let* t = init ~root ~fresh:false ~lower_root:(Some lower_root) () in - let* main = S.main t.repo in + let t = init ~root ~fresh:false ~lower_root:(Some lower_root) () in + let main = S.main t.repo in [%log.debug "Run GC on commit that is now in lower"]; - let* head = S.Head.get main in + let head = S.Head.get main in let () = match Irmin_pack_unix.Pack_key.inspect (S.Commit.key head) with | Direct { volume_identifier; _ } -> @@ -782,8 +792,8 @@ module Gc_archival = struct true | _ -> assert false in - let* () = start_gc t head in - let* () = finalise_gc t in + let () = start_gc t head in + let () = finalise_gc t in S.Repo.close t.repo module B = struct @@ -793,39 +803,38 @@ module Gc_archival = struct init ?lru_size ?readonly ?fresh ~root ~lower_root:(Some lower_root) () let check_gced t c s = - let* c = S.Commit.of_key t.repo (S.Commit.key c) in - Alcotest.(check bool s true (Option.is_some c)); - Lwt.return_unit + let c = S.Commit.of_key t.repo (S.Commit.key c) in + Alcotest.(check bool s true (Option.is_some c)) let check_removed = check_not_found end let gc_archival_multiple_volumes () = - let* t = B.init () in - let* t, c1 = commit_1 t in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in - let* t = checkout_exn t c1 in - let* t, c3 = commit_3 t in - let* t = checkout_exn t c2 in - let* t, c4 = commit_4 t in + let t = B.init () in + let t, c1 = commit_1 t in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in + let t = checkout_exn t c1 in + let t, c3 = commit_3 t in + let t = checkout_exn t c2 in + let t, c4 = commit_4 t in [%log.debug "Gc c1, c2, c3, keep c4"]; - let* () = start_gc t c4 in - let* () = finalise_gc t in + let () = start_gc t c4 in + let () = finalise_gc t in [%log.debug "Add a new volume"]; S.add_volume t.repo; - let* t = checkout_exn t c4 in - let* t, c5 = commit_5 t in - let* () = check_5 t c5 in + let t = checkout_exn t c4 in + let t, c5 = commit_5 t in + let () = check_5 t c5 in [%log.debug "Gc c4, keep c5"]; - let* () = start_gc t c5 in - let* () = finalise_gc t in - let* () = check_5 t c5 in - let* () = B.check_gced t c1 "gced c1" in - let* () = B.check_gced t c2 "gced c2" in - let* () = B.check_removed t c3 "gced c3" in - let* () = B.check_gced t c4 "gced c4" in - let* () = + let () = start_gc t c5 in + let () = finalise_gc t in + let () = check_5 t c5 in + let () = B.check_gced t c1 "gced c1" in + let () = B.check_gced t c2 "gced c2" in + let () = B.check_removed t c3 "gced c3" in + let () = B.check_gced t c4 "gced c4" in + let () = Alcotest.check_raises_pack_error "Cannot GC on commit older than c5" (function `Gc_disallowed _ -> true | _ -> false) (fun () -> start_gc t c4) @@ -988,35 +997,35 @@ module Concurrent_gc = struct (** Check that calling reload in RO will clear the LRU only after GC. *) let ro_reload_clears_lru () = - let* rw_t = init () in - let* ro_t = + let rw_t = init () in + let ro_t = init ~lru_size:100 ~readonly:true ~fresh:false ~root:rw_t.root () in (* Create some commits in RW *) - let* rw_t, c1 = commit_1 rw_t in - let* rw_t = checkout_exn rw_t c1 in - let* rw_t, c2 = commit_2 rw_t in - let* rw_t = checkout_exn rw_t c2 in - let* rw_t, c3 = commit_3 rw_t in + let rw_t, c1 = commit_1 rw_t in + let rw_t = checkout_exn rw_t c1 in + let rw_t, c2 = commit_2 rw_t in + let rw_t = checkout_exn rw_t c2 in + let rw_t, c3 = commit_3 rw_t in (* Reload RO to get all changes, and read some data *) S.reload ro_t.repo; - let* () = check_3 ro_t c3 in + let () = check_3 ro_t c3 in let count_before_reload = lru_hits () in (* Reload should not clear LRU *) S.reload ro_t.repo; - let* () = check_3 ro_t c3 in + let () = check_3 ro_t c3 in Alcotest.(check bool) "reload does not clear LRU" true (count_before_reload < lru_hits ()); (* GC *) let count_before_gc = lru_hits () in - let* () = start_gc rw_t c2 in - let* () = finalise_gc rw_t in + let () = start_gc rw_t c2 in + let () = finalise_gc rw_t in (* Reload RO to get changes and clear LRU, and read some data *) S.reload ro_t.repo; - let* () = check_3 ro_t c3 in + let () = check_3 ro_t c3 in Alcotest.(check int) "reload does clear LRU" count_before_gc (lru_hits ()); - let* () = S.Repo.close rw_t.repo in + let () = S.Repo.close rw_t.repo in S.Repo.close ro_t.repo (** Check that calling close during a gc kills the gc without finalising it. @@ -1368,9 +1377,9 @@ module Split = struct let split_always_indexed_from_v2_store () = let root = create_from_v2_always_test_env () in - let* t = init ~readonly:false ~fresh:false ~root () in - let* _c0 = load_commit t "22e159de13b427226e5901defd17f0c14e744205" in - let* t, _c1 = commit_1 t in + let t = init ~readonly:false ~fresh:false ~root () in + let _c0 = load_commit t "22e159de13b427226e5901defd17f0c14e744205" in + let t, _c1 = commit_1 t in let f () = S.split t.repo in Alcotest.check_raises "split should raise disallowed exception" (Irmin_pack_unix.Errors.Pack_error `Split_disallowed) f; diff --git a/test/irmin-pack/test_gc.mli b/test/irmin-pack/test_gc.mli index c063f240a4..431ad1d82a 100644 --- a/test/irmin-pack/test_gc.mli +++ b/test/irmin-pack/test_gc.mli @@ -19,7 +19,7 @@ module Gc : sig end module Gc_archival : sig - val tests : unit Alcotest_lwt.test_case list + val tests : unit Alcotest.test_case list end module Concurrent_gc : sig diff --git a/test/irmin-pack/test_indexing_strategy.ml b/test/irmin-pack/test_indexing_strategy.ml index dc08546f17..708aa5e910 100644 --- a/test/irmin-pack/test_indexing_strategy.ml +++ b/test/irmin-pack/test_indexing_strategy.ml @@ -34,10 +34,10 @@ let config ~indexing_strategy ?(readonly = false) ?(fresh = false) () = let test_unique_when_switched () = let value = "Welt" in let get_contents_key store path = - let* k = Store.key store path in + let k = Store.key store path in match Option.get k with | `Node _ -> assert false - | `Contents contents_key -> Lwt.return contents_key + | `Contents contents_key -> contents_key in let get_direct_key key = match Irmin_pack_unix.Pack_key.inspect key with @@ -55,22 +55,22 @@ let test_unique_when_switched () = in (* 1. open store with always indexing, verify same offsets *) - let* repo = + let repo = Store.Repo.v @@ config ~indexing_strategy:Irmin_pack.Indexing_strategy.always ~fresh:true () in - let* store = Store.main repo in - let* first_key = + let store = Store.main repo in + let first_key = let first_path = [ "hello" ] in - let* () = + let () = Store.set_exn ~info:(fun () -> Store.Info.empty) store first_path value in get_contents_key store first_path in - let* second_key = + let second_key = let second_path = [ "salut" ] in - let* () = + let () = Store.set_exn ~info:(fun () -> Store.Info.empty) store second_path value in get_contents_key store second_path @@ -80,20 +80,18 @@ let test_unique_when_switched () = (get_key_offset first_key) (get_key_offset second_key); - let* () = Store.Repo.close repo in + Store.Repo.close repo; (* 2. re-open store with minimal indexing, verify new offset *) - let* repo = + let repo = Store.Repo.v @@ config ~indexing_strategy:Irmin_pack.Indexing_strategy.minimal ~fresh:false () in - let* store = Store.main repo in - let* third_key = + let store = Store.main repo in + let third_key = let third_path = [ "hola" ] in - let* () = - Store.set_exn ~info:(fun () -> Store.Info.empty) store third_path value - in + Store.set_exn ~info:(fun () -> Store.Info.empty) store third_path value; get_contents_key store third_path in Alcotest.(check bool) @@ -111,6 +109,6 @@ let test_unique_when_switched () = let tests = [ - Alcotest_lwt.test_case "test unique when switching strategies" `Quick - (fun _switch () -> test_unique_when_switched ()); + Alcotest.test_case "test unique when switching strategies" `Quick + test_unique_when_switched; ] diff --git a/test/irmin-pack/test_indexing_strategy.mli b/test/irmin-pack/test_indexing_strategy.mli index 3c5b234dea..601ae9bf53 100644 --- a/test/irmin-pack/test_indexing_strategy.mli +++ b/test/irmin-pack/test_indexing_strategy.mli @@ -14,4 +14,4 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -val tests : unit Alcotest_lwt.test_case list +val tests : unit Alcotest.test_case list diff --git a/test/irmin-pack/test_inode.ml b/test/irmin-pack/test_inode.ml index c0c918117b..026906586d 100644 --- a/test/irmin-pack/test_inode.ml +++ b/test/irmin-pack/test_inode.ml @@ -625,7 +625,7 @@ let test_intermediate_inode_as_root ~indexing_strategy = Inode.batch t.store (fun store -> with_exn (fun () -> Inode.add store v)) let test_invalid_depth_intermediate_inode ~indexing_strategy = - let* t = Context_mock.get_store ~indexing_strategy () in + let t = Context_mock.get_store ~indexing_strategy () in let { Context_mock.foo; bar; _ } = t in let gen_step = Inode_permutations_generator.gen_step (module Inter_mock) in let s000, s001, s010 = @@ -636,13 +636,13 @@ let test_invalid_depth_intermediate_inode ~indexing_strategy = Inode_mock.Val.of_list [ (s000, normal foo); (s001, normal bar); (s010, normal foo) ] in - let* h_depth0 = + let h_depth0 = Inode_mock.batch t.store @@ fun store -> Inode_mock.add store v0 in (* On inode with depth=0 *) - let* v = - Inode_mock.find t.store h_depth0 >|= function + let v = + match Inode_mock.find t.store h_depth0 with | None -> Alcotest.fail "Could not fetch inode from backend" | Some v -> v in @@ -659,8 +659,7 @@ let test_invalid_depth_intermediate_inode ~indexing_strategy = () | _ -> Alcotest.fail "Wrong exception - should have raised Invalid_depth" in - let* () = Context_mock.close t in - Lwt.return_unit + Context_mock.close t let test_intermediate_inode_as_root () = let () = test_invalid_depth_intermediate_inode ~indexing_strategy:`always in @@ -705,7 +704,7 @@ let test_concrete_inodes ~indexing_strategy = let test_invalid_depth_concrete_inodes ~indexing_strategy = let module C = Inter.Val.Concrete in - let* t = Context.get_store ~indexing_strategy () in + let t = Context.get_store ~indexing_strategy () in (* idea is to try and directly construct a Concrete that has a bad depth structure ie *) (* "Tree": { *) @@ -738,8 +737,7 @@ let test_invalid_depth_concrete_inodes ~indexing_strategy = Alcotest.fail "of_concrete - should be Invalid_depth error" in - let* () = Context.close t in - Lwt.return_unit + Context.close t let test_concrete_inodes () = let () = test_invalid_depth_concrete_inodes ~indexing_strategy:`always in diff --git a/test/irmin-pack/test_lower.ml b/test/irmin-pack/test_lower.ml index b0409bc076..58d5ed2f51 100644 --- a/test/irmin-pack/test_lower.ml +++ b/test/irmin-pack/test_lower.ml @@ -39,17 +39,14 @@ module Direct_tc = struct let$ lower = Lower.v ~readonly:false ~volume_num:0 lower_root in Alcotest.(check int) "0 volumes" 0 (Lower.volume_num lower); let _ = Lower.close lower in - Lwt.return_unit + () let test_volume_num () = let lower_root = create_lower_root () in let result = Lower.v ~readonly:false ~volume_num:1 lower_root in - let () = - match result with - | Error (`Volume_missing _) -> () - | _ -> Alcotest.fail "volume_num too high should return an error" - in - Lwt.return_unit + match result with + | Error (`Volume_missing _) -> () + | _ -> Alcotest.fail "volume_num too high should return an error" let test_add_volume () = let lower_root = create_lower_root () in @@ -59,7 +56,7 @@ module Direct_tc = struct let$ _ = Lower.reload ~volume_num:1 lower in Alcotest.(check int) "1 volume after reload" 1 (Lower.volume_num lower); let _ = Lower.close lower in - Lwt.return_unit + () let test_add_volume_ro () = let lower_root = create_lower_root () in @@ -71,7 +68,7 @@ module Direct_tc = struct | _ -> Alcotest.fail "cannot add volume to ro lower" in let _ = Lower.close lower in - Lwt.return_unit + () let test_add_multiple_empty () = let lower_root = create_lower_root () in @@ -84,7 +81,7 @@ module Direct_tc = struct | _ -> Alcotest.fail "cannot add multiple empty volumes" in let _ = Lower.close lower in - Lwt.return_unit + () let test_find_volume () = let lower_root = create_lower_root () in @@ -107,7 +104,7 @@ module Direct_tc = struct let volume = Lower.find_volume ~off:(Int63.of_int 21) lower in Alcotest.(check bool) "found volume" true (Option.is_some volume); let _ = Lower.close lower in - Lwt.return_unit + () let test_read_exn () = let lower_root = create_lower_root () in @@ -148,7 +145,7 @@ module Direct_tc = struct "check volume read" test_str (Bytes.unsafe_to_string buf); let _ = Lower.close lower in - Lwt.return_unit + () end module Store_tc = struct @@ -223,17 +220,16 @@ module Store_tc = struct | _ -> ()) index in - Lwt_list.map_s + List.map (fun hash -> [%log.debug "read %a" Irmin.Type.(pp Store.Hash.t) hash]; - let* commit = Store.Commit.of_hash repo hash in - match commit with + match Store.Commit.of_hash repo hash with | None -> Alcotest.fail "failed to read commit" | Some commit -> Store.Tree.fold (Store.Commit.tree commit) ()) !commits let test_create () = - let* repo = init () in + let repo = init () in (* A newly created store with a lower should have an empty volume. *) let volume_num = count_volumes repo in Alcotest.(check int) "volume_num is 1" 1 volume_num; @@ -241,41 +237,41 @@ module Store_tc = struct let test_create_nested () = let root, lower_root = fresh_roots ~make_root:false () in - let* repo = config ~fresh:true ~lower_root root |> Store.Repo.v in + let repo = config ~fresh:true ~lower_root root |> Store.Repo.v in let volume_num = count_volumes repo in Alcotest.(check int) "volume_num is 1" 1 volume_num; Store.Repo.close repo let test_open_rw_lower () = let root, lower_root = fresh_roots ~make_root:false () in - let* repo = config ~fresh:true root |> Store.Repo.v in - let* () = Store.Repo.close repo in - let* repo = config ~fresh:false ~lower_root root |> Store.Repo.v in + let repo = config ~fresh:true root |> Store.Repo.v in + let () = Store.Repo.close repo in + let repo = config ~fresh:false ~lower_root root |> Store.Repo.v in let volume_num = count_volumes repo in Alcotest.(check int) "volume_num is 1" 1 volume_num; Store.Repo.close repo let test_add_volume_during_gc () = - let* repo = init () in - let* main = Store.main repo in - let* () = + let repo = init () in + let main = Store.main repo in + let () = Store.set_exn ~info:(fun () -> Store.Info.v ~author:"tester" Int64.zero) main [ "a" ] "a" in - let* c = Store.Head.get main in - let* _ = Store.Gc.start_exn repo (Store.Commit.key c) in - let* () = - Alcotest.check_raises_lwt "add volume during gc" + let c = Store.Head.get main in + let _ = Store.Gc.start_exn repo (Store.Commit.key c) in + let () = + Alcotest.check_raises "add volume during gc" (Irmin_pack_unix.Errors.Pack_error `Add_volume_forbidden_during_gc) (fun () -> Store.add_volume repo |> Lwt.return) in Store.Repo.close repo let test_add_volume_wo_lower () = - let* repo = init ~include_lower:false () in - let* () = - Alcotest.check_raises_lwt "add volume w/o lower" + let repo = init ~include_lower:false () in + let () = + Alcotest.check_raises "add volume w/o lower" (Irmin_pack_unix.Errors.Pack_error `Add_volume_requires_lower) (fun () -> Store.add_volume repo |> Lwt.return) in @@ -283,53 +279,53 @@ module Store_tc = struct let test_add_volume_reopen () = let root, lower_root = fresh_roots () in - let* repo = Store.Repo.v (config ~fresh:true ~lower_root root) in - let* main = Store.main repo in + let repo = Store.Repo.v (config ~fresh:true ~lower_root root) in + let main = Store.main repo in let info () = Store.Info.v ~author:"test" Int64.zero in - let* () = Store.set_exn ~info main [ "a" ] "a" in - let* c1 = Store.Head.get main in - let* _ = Store.Gc.start_exn repo (Store.Commit.key c1) in - let* _ = Store.Gc.finalise_exn ~wait:true repo in + let () = Store.set_exn ~info main [ "a" ] "a" in + let c1 = Store.Head.get main in + let _ = Store.Gc.start_exn repo (Store.Commit.key c1) in + let _ = Store.Gc.finalise_exn ~wait:true repo in let () = Store.add_volume repo in Alcotest.(check int) "two volumes" 2 (count_volumes repo); - let* _ = Store.Repo.close repo in - let* repo = Store.Repo.v (config ~fresh:false ~lower_root root) in + let _ = Store.Repo.close repo in + let repo = Store.Repo.v (config ~fresh:false ~lower_root root) in Alcotest.(check int) "two volumes after re-open" 2 (count_volumes repo); Store.Repo.close repo let test_migrate () = let root, lower_root = fresh_roots () in (* Create without a lower *) - let* repo = Store.Repo.v (config ~fresh:true root) in + let repo = Store.Repo.v (config ~fresh:true root) in Alcotest.(check int) "volume_num is 0" 0 (count_volumes repo); - let* main = Store.main repo in + let main = Store.main repo in let info () = Store.Info.v ~author:"test" Int64.zero in - let* () = Store.set_exn ~info main [ "a" ] "a" in - let* () = Store.Repo.close repo in + let () = Store.set_exn ~info main [ "a" ] "a" in + let () = Store.Repo.close repo in (* Reopen with a lower to trigger the migration *) - let* repo = Store.Repo.v (config ~lower_root root) in + let repo = Store.Repo.v (config ~lower_root root) in Alcotest.(check int) "volume_num is 1" 1 (count_volumes repo); - let* main = Store.main repo in - let* a = Store.get main [ "a" ] in + let main = Store.main repo in + let a = Store.get main [ "a" ] in Alcotest.(check string) "migrated commit" "a" a; Alcotest.(check bool) "no latest GC commit" true (Option.is_none (Store.Gc.latest_gc_target repo)); - let* () = Store.set_exn ~info main [ "a" ] "b" in - let* () = Store.Repo.close repo in + let () = Store.set_exn ~info main [ "a" ] "b" in + let () = Store.Repo.close repo in (* Reopen with the same lower and check reads *) - let* repo = Store.Repo.v (config ~lower_root root) in + let repo = Store.Repo.v (config ~lower_root root) in Alcotest.(check int) "volume_num is 1" 1 (count_volumes repo); - let* main = Store.main repo in - let* b = Store.get main [ "a" ] in + let main = Store.main repo in + let b = Store.get main [ "a" ] in Alcotest.(check string) "upper commit" "b" b; - let* main_commit = Store.Head.get main in + let main_commit = Store.Head.get main in let parent_key = List.hd @@ Store.Commit.parents main_commit in - let* parent = Store.Commit.of_key repo parent_key in + let parent = Store.Commit.of_key repo parent_key in let previous_tree = Store.Commit.tree @@ Option.get parent in - let* a_opt = Store.Tree.find previous_tree [ "a" ] in + let a_opt = Store.Tree.find previous_tree [ "a" ] in Alcotest.(check (option string)) "upper to lower" (Some "a") a_opt; - let* _ = read_everything repo in + let _ = read_everything repo in Store.Repo.close repo (* Tests that dead header is handled appropriately *) @@ -342,8 +338,8 @@ module Store_tc = struct setup_test_env ~root_archive ~root_local_build:root; let lower_root = root / "lower" in (* Open store and trigger migration. This should succeed. *) - let* repo = Store.Repo.v (config ~fresh:false ~lower_root root) in - let* _ = read_everything repo in + let repo = Store.Repo.v (config ~fresh:false ~lower_root root) in + let _ = read_everything repo in Store.Repo.close repo let test_migrate_v3 () = @@ -354,9 +350,9 @@ module Store_tc = struct setup_test_env ~root_archive ~root_local_build:root; let lower_root = root / "lower" in (* Open store and trigger migration. This should succeed. *) - let* repo = Store.Repo.v (config ~fresh:false ~lower_root root) in - let* _ = read_everything repo in - let* _ = Store.Repo.close repo in + let repo = Store.Repo.v (config ~fresh:false ~lower_root root) in + let _ = read_everything repo in + let _ = Store.Repo.close repo in (* always indexing *) let ( / ) = Filename.concat in @@ -365,79 +361,79 @@ module Store_tc = struct setup_test_env ~root_archive ~root_local_build:root; let lower_root = root / "lower" in (* Open store and trigger migration. This should succeed. *) - let* repo = Store.Repo.v (config ~fresh:false ~lower_root root) in - let* _ = read_everything repo in + let repo = Store.Repo.v (config ~fresh:false ~lower_root root) in + let _ = read_everything repo in Store.Repo.close repo let test_migrate_then_gc () = let root, lower_root = fresh_roots () in (* Create without a lower *) - let* repo = Store.Repo.v (config ~fresh:true root) in + let repo = Store.Repo.v (config ~fresh:true root) in Alcotest.(check int) "volume_num is 0" 0 (count_volumes repo); - let* main = Store.main repo in + let main = Store.main repo in let info () = Store.Info.v ~author:"test" Int64.zero in - let* () = Store.set_exn ~info main [ "a" ] "a" in - let* () = Store.Repo.close repo in + let () = Store.set_exn ~info main [ "a" ] "a" in + let () = Store.Repo.close repo in (* Reopen with a lower to trigger the migration *) - let* repo = Store.Repo.v (config ~lower_root root) in + let repo = Store.Repo.v (config ~lower_root root) in Alcotest.(check int) "volume_num is 1" 1 (count_volumes repo); (* Add two commits *) - let* main = Store.main repo in - let* () = Store.set_exn ~info main [ "b" ] "b" in - let* main = Store.main repo in - let* b_commit = Store.Head.get main in - let* () = Store.set_exn ~info main [ "c" ] "c" in + let main = Store.main repo in + let () = Store.set_exn ~info main [ "b" ] "b" in + let main = Store.main repo in + let b_commit = Store.Head.get main in + let () = Store.set_exn ~info main [ "c" ] "c" in (* GC at [b] requires reading [a] data from the lower volume *) - let* _ = Store.Gc.start_exn repo (Store.Commit.key b_commit) in - let* _ = Store.Gc.finalise_exn ~wait:true repo in - let* _ = read_everything repo in + let _ = Store.Gc.start_exn repo (Store.Commit.key b_commit) in + let _ = Store.Gc.finalise_exn ~wait:true repo in + let _ = read_everything repo in Store.Repo.close repo let test_migrate_then_gc_in_lower () = let root, lower_root = fresh_roots () in (* Create without a lower *) - let* repo = Store.Repo.v (config ~fresh:true root) in + let repo = Store.Repo.v (config ~fresh:true root) in Alcotest.(check int) "volume_num is 0" 0 (count_volumes repo); - let* main = Store.main repo in + let main = Store.main repo in let info () = Store.Info.v ~author:"test" Int64.zero in - let* () = Store.set_exn ~info main [ "a" ] "a" in - let* a_commit = Store.Head.get main in - let* () = Store.set_exn ~info main [ "b" ] "b" in - let* () = Store.Repo.close repo in + let () = Store.set_exn ~info main [ "a" ] "a" in + let a_commit = Store.Head.get main in + let () = Store.set_exn ~info main [ "b" ] "b" in + let () = Store.Repo.close repo in (* Reopen with a lower to trigger the migration *) - let* repo = Store.Repo.v (config ~lower_root root) in + let repo = Store.Repo.v (config ~lower_root root) in Alcotest.(check int) "volume_num is 1" 1 (count_volumes repo); (* [a] is now in the lower but GC should still succeed Important: we call GC on a commit that is not the latest in the lower (ie [b]) to ensure its offset is not equal to the start offset of the upper. *) - let* _ = Store.Gc.start_exn repo (Store.Commit.key a_commit) in - let* _ = Store.Gc.finalise_exn ~wait:true repo in + let _ = Store.Gc.start_exn repo (Store.Commit.key a_commit) in + let _ = Store.Gc.finalise_exn ~wait:true repo in Store.Repo.close repo let test_volume_data_locality () = let root, lower_root = fresh_roots () in - let* repo = Store.Repo.v (config ~fresh:true ~lower_root root) in - let* main = Store.main repo in + let repo = Store.Repo.v (config ~fresh:true ~lower_root root) in + let main = Store.main repo in let info () = Store.Info.v ~author:"test" Int64.zero in [%log.debug "add c1"]; - let* () = Store.set_exn ~info main [ "c1" ] "a" in - let* c1 = Store.Head.get main in + let () = Store.set_exn ~info main [ "c1" ] "a" in + let c1 = Store.Head.get main in [%log.debug "GC c1"]; - let* _ = Store.Gc.start_exn repo (Store.Commit.key c1) in - let* _ = Store.Gc.finalise_exn ~wait:true repo in + let _ = Store.Gc.start_exn repo (Store.Commit.key c1) in + let _ = Store.Gc.finalise_exn ~wait:true repo in let () = Store.add_volume repo in [%log.debug "add c2, c3, c4"]; - let* () = Store.set_exn ~info main [ "c2" ] "b" in - let* () = Store.set_exn ~info main [ "c3" ] "c" in - let* c3 = Store.Head.get main in - let* () = Store.set_exn ~info main [ "c4" ] "d" in - let* () = Store.set_exn ~info main [ "c5" ] "e" in - let* c5 = Store.Head.get main in + let () = Store.set_exn ~info main [ "c2" ] "b" in + let () = Store.set_exn ~info main [ "c3" ] "c" in + let c3 = Store.Head.get main in + let () = Store.set_exn ~info main [ "c4" ] "d" in + let () = Store.set_exn ~info main [ "c5" ] "e" in + let c5 = Store.Head.get main in [%log.debug "GC c5"]; - let* _ = Store.Gc.start_exn repo (Store.Commit.key c5) in - let* _ = Store.Gc.finalise_exn ~wait:true repo in + let _ = Store.Gc.start_exn repo (Store.Commit.key c5) in + let _ = Store.Gc.finalise_exn ~wait:true repo in let get_direct_key key = match Irmin_pack_unix.Pack_key.inspect key with | Direct { offset; hash; length; volume_identifier } -> @@ -447,14 +443,14 @@ module Store_tc = struct (* NOTE: we need to lookup c3 again so that its volume identifier is on its key *) let _, hash, _, _ = get_direct_key (Store.Commit.key c3) in - let* c3 = Store.Commit.of_hash repo hash in + let c3 = Store.Commit.of_hash repo hash in let c3 = Option.get c3 in let _, _, _, identifier = get_direct_key (Store.Commit.key c3) in let identifier = Option.get identifier in [%log.debug "Check c3 tree items are in volume %s" identifier]; - let* c3 = Store.Commit.of_key repo (Store.Commit.key c3) in + let c3 = Store.Commit.of_key repo (Store.Commit.key c3) in let tree = Store.Commit.tree (Option.get c3) in - let* () = + let () = let get_volume_identifier key = let _, _, _, identifier = get_direct_key key in match identifier with @@ -474,7 +470,7 @@ module Store_tc = struct [%log.debug "identifier: %s" key_identifier]; Alcotest.(check string) "key is in expected volume" identifier key_identifier; - Lwt.return a) + a) tree () in Store.Repo.close repo @@ -482,16 +478,16 @@ module Store_tc = struct let test_cleanup () = let root, lower_root = fresh_roots () in [%log.debug "create store with data and run GC"]; - let* repo = Store.Repo.v (config ~fresh:true ~lower_root root) in - let* main = Store.main repo in + let repo = Store.Repo.v (config ~fresh:true ~lower_root root) in + let main = Store.main repo in let info () = Store.Info.v ~author:"test" Int64.zero in - let* () = Store.set_exn ~info main [ "a" ] "a" in - let* c1 = Store.Head.get main in - let* _ = Store.Gc.start_exn repo (Store.Commit.key c1) in - let* _ = Store.Gc.finalise_exn ~wait:true repo in + let () = Store.set_exn ~info main [ "a" ] "a" in + let c1 = Store.Head.get main in + let _ = Store.Gc.start_exn repo (Store.Commit.key c1) in + let _ = Store.Gc.finalise_exn ~wait:true repo in let volume_root = volume_path repo Int63.zero in let generation = generation repo in - let* () = Store.Repo.close repo in + let () = Store.Repo.close repo in [%log.debug "test volume.1.control is moved to volume.control"]; let volume_cf_gen_path = Irmin_pack.Layout.V5.Volume.control_gc_tmp ~generation ~root:volume_root @@ -500,7 +496,7 @@ module Store_tc = struct Irmin_pack.Layout.V5.Volume.control ~root:volume_root in let$ () = Io.move_file ~src:volume_cf_path ~dst:volume_cf_gen_path in - let* repo = Store.Repo.v (config ~fresh:false ~lower_root root) in + let repo = Store.Repo.v (config ~fresh:false ~lower_root root) in let () = match Io.classify_path volume_cf_path with | `File -> [%log.debug "control file exists"] @@ -518,7 +514,7 @@ module Store = struct include Store_tc let tests = - Alcotest_lwt. + Alcotest. [ quick_tc "create store" test_create; quick_tc "create nested" test_create_nested; @@ -541,7 +537,7 @@ module Direct = struct include Direct_tc let tests = - Alcotest_lwt. + Alcotest. [ quick_tc "empty lower" test_empty; quick_tc "volume_num too high" test_volume_num; diff --git a/test/irmin-pack/test_lower.mli b/test/irmin-pack/test_lower.mli index 416b7dce21..a2a5f61123 100644 --- a/test/irmin-pack/test_lower.mli +++ b/test/irmin-pack/test_lower.mli @@ -15,9 +15,9 @@ *) module Store : sig - val tests : unit Alcotest_lwt.test_case list + val tests : unit Alcotest.test_case list end module Direct : sig - val tests : unit Alcotest_lwt.test_case list + val tests : unit Alcotest.test_case list end diff --git a/test/irmin-pack/test_mapping.ml b/test/irmin-pack/test_mapping.ml index a5aa03c280..efeca51fc7 100644 --- a/test/irmin-pack/test_mapping.ml +++ b/test/irmin-pack/test_mapping.ml @@ -104,8 +104,8 @@ let test ~full_seg_length ~random_test_count = let tests = [ - Alcotest.test_case "test mapping on small inputs" `Quick - (fun _switch () -> test ~full_seg_length:10 ~random_test_count:1000); - Alcotest.test_case "test mapping on large inputs" `Quick - (fun _switch () -> test ~full_seg_length:10000 ~random_test_count:100); + Alcotest.test_case "test mapping on small inputs" `Quick (fun () -> + test ~full_seg_length:10 ~random_test_count:1000); + Alcotest.test_case "test mapping on large inputs" `Quick (fun () -> + test ~full_seg_length:10000 ~random_test_count:100); ] diff --git a/test/irmin-pack/test_nearest_geq.ml b/test/irmin-pack/test_nearest_geq.ml index badc022413..3fa4ea2adc 100644 --- a/test/irmin-pack/test_nearest_geq.ml +++ b/test/irmin-pack/test_nearest_geq.ml @@ -18,10 +18,6 @@ let test_nearest_geq () = Alcotest.(check geq) "6" (nearest_geq 6) (Some 3); Alcotest.(check geq) "7" (nearest_geq 7) (Some 3); Alcotest.(check geq) "8" (nearest_geq 8) None; - Lwt.return_unit + () -let tests = - [ - Alcotest_lwt.test_case "test_nearest_geq" `Quick (fun _switch () -> - test_nearest_geq ()); - ] +let tests = [ Alcotest.test_case "test_nearest_geq" `Quick test_nearest_geq ] diff --git a/test/irmin-pack/test_pack.ml b/test/irmin-pack/test_pack.ml index 00f8751433..e0c8d27581 100644 --- a/test/irmin-pack/test_pack.ml +++ b/test/irmin-pack/test_pack.ml @@ -515,7 +515,7 @@ module Layout = struct c `Unknown (classif "store.00.prefix"); c `Unknown (classif "store.01.prefix"); c `Unknown (classif "./store.0.prefix"); - Lwt.return_unit + () let test_classify_volume_filename () = let module V1_and_v2 = Irmin_pack.Layout.V1_and_v2 in @@ -532,14 +532,14 @@ module Layout = struct c `Unknown (classif "store.00.prefix"); c `Unknown (classif "store.01.prefix"); c `Unknown (classif "./store.0.prefix"); - Lwt.return_unit + () let tests = [ - Alcotest.test_case "classify upper files" `Quick (fun _switch -> - test_classify_upper_filename); - Alcotest.test_case "classify volume files" `Quick (fun _switch -> - test_classify_volume_filename); + Alcotest.test_case "classify upper files" `Quick + test_classify_upper_filename; + Alcotest.test_case "classify volume files" `Quick + test_classify_volume_filename; ] end diff --git a/test/irmin-pack/test_ranges.ml b/test/irmin-pack/test_ranges.ml index 0fe759992b..a015453aa2 100644 --- a/test/irmin-pack/test_ranges.ml +++ b/test/irmin-pack/test_ranges.ml @@ -31,8 +31,6 @@ let test () = (fun ~off ~len -> output := (Int63.to_int off, Int63.to_int len) :: !output) ranges; let expected = [ (90, 10); (87, 1); (70, 15); (50, 17) ] in - Alcotest.(check (list (pair int int))) "out of order" expected !output; - Lwt.return_unit + Alcotest.(check (list (pair int int))) "out of order" expected !output -let tests = - [ Alcotest_lwt.test_case "test ranges" `Quick (fun _switch () -> test ()) ] +let tests = [ Alcotest.test_case "test ranges" `Quick test ] diff --git a/test/irmin-pack/test_snapshot.ml b/test/irmin-pack/test_snapshot.ml index aa8a0f1bd5..023d5923c9 100644 --- a/test/irmin-pack/test_snapshot.ml +++ b/test/irmin-pack/test_snapshot.ml @@ -248,45 +248,45 @@ let test_export_import_reexport () = rm_dir root_export; rm_dir root_import; (* export a snapshot. *) - let* repo_export = + let repo_export = S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_export) in let tree = S.Tree.singleton [ "a" ] "y" in - let* parent_commit = S.Commit.v repo_export ~parents:[] ~info tree in + let parent_commit = S.Commit.v repo_export ~parents:[] ~info tree in let parent_key = Irmin_pack_unix.Pack_key.v_indexed (S.Commit.hash parent_commit) in let tree = S.Tree.singleton [ "a" ] "x" in - let* _ = S.Commit.v repo_export ~parents:[ parent_key ] ~info tree in + let _ = S.Commit.v repo_export ~parents:[ parent_key ] ~info tree in let root_key = S.Tree.key tree |> Option.get in let buf = Buffer.create 0 in - let* _ = S.Snapshot.export repo_export (encode_with_size buf) ~root_key in - let* () = S.Repo.close repo_export in + let _ = S.Snapshot.export repo_export (encode_with_size buf) ~root_key in + let () = S.Repo.close repo_export in (* buf contains the snapshot, we can rm root_export and import the snapshot in a new store, with the key parent of type Indexed. *) rm_dir root_export; - let* repo_import = + let repo_import = S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_import) in - let* _, key = Buffer.contents buf |> restore repo_import in + let _, key = Buffer.contents buf |> restore repo_import in let key = Option.get key in - let* tree = S.Tree.of_key repo_import (`Node key) in + let tree = S.Tree.of_key repo_import (`Node key) in let tree = Option.get tree in - let* commit = S.Commit.v repo_import ~info ~parents:[ parent_key ] tree in + let commit = S.Commit.v repo_import ~info ~parents:[ parent_key ] tree in let commit_key = S.Commit.key commit in let commit_hash = S.Commit.hash commit in (* export the gc-based snapshot in a clean root_export. *) - let* () = S.create_one_commit_store repo_import commit_key root_export in - let* () = S.Repo.close repo_import in + let () = S.create_one_commit_store repo_import commit_key root_export in + let () = S.Repo.close repo_import in (* open the new store and check that everything is readable. *) - let* repo_export = + let repo_export = S.Repo.v (config ~readonly:false ~fresh:false ~indexing_strategy root_export) in - let* commit = S.Commit.of_hash repo_export commit_hash in + let commit = S.Commit.of_hash repo_export commit_hash in let commit = Option.get commit in let tree = S.Commit.tree commit in - let* got = S.Tree.find tree [ "a" ] in + let got = S.Tree.find tree [ "a" ] in Alcotest.(check (option string)) "find blob" (Some "x") got; S.Repo.close repo_export diff --git a/test/irmin-tezos/dune b/test/irmin-tezos/dune index 43186b51d4..63b30a4e56 100644 --- a/test/irmin-tezos/dune +++ b/test/irmin-tezos/dune @@ -6,7 +6,7 @@ (executable (name generate) (modules generate) - (libraries irmin-tezos irmin-pack irmin-pack.unix)) + (libraries eio_main irmin-tezos irmin-pack irmin-pack.unix)) (rule (alias generate-cli-test-data) diff --git a/test/irmin-tezos/generate.ml b/test/irmin-tezos/generate.ml index 128c1f3e15..151b0d8f4c 100644 --- a/test/irmin-tezos/generate.ml +++ b/test/irmin-tezos/generate.ml @@ -14,8 +14,6 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Lwt.Syntax - let rm_dir data_dir = if Sys.file_exists data_dir then let cmd = Printf.sprintf "rm -rf %s" data_dir in @@ -42,34 +40,34 @@ module Generator = struct let info = Store.Info.empty - let create_store ?(before_closing = fun _repo _head -> Lwt.return_unit) - indexing_strategy path = + let create_store ?(before_closing = fun _repo _head -> ()) indexing_strategy + path = rm_dir path; let large_contents = String.make 4096 'Z' in - let* rw = Store.Repo.v (config ~indexing_strategy path) in + let rw = Store.Repo.v (config ~indexing_strategy path) in let tree = Store.Tree.singleton [ "a"; "b1"; "c1"; "d1"; "e1" ] "x1" in - let* tree = Store.Tree.add tree [ "a"; "b1"; "c1"; "d2"; "e2" ] "x2" in - let* tree = Store.Tree.add tree [ "a"; "b1"; "c1"; "d3"; "e3" ] "x2" in - let* tree = Store.Tree.add tree [ "a"; "b2"; "c2"; "e3" ] "x2" in - let* c1 = Store.Commit.v rw ~parents:[] ~info tree in + let tree = Store.Tree.add tree [ "a"; "b1"; "c1"; "d2"; "e2" ] "x2" in + let tree = Store.Tree.add tree [ "a"; "b1"; "c1"; "d3"; "e3" ] "x2" in + let tree = Store.Tree.add tree [ "a"; "b2"; "c2"; "e3" ] "x2" in + let c1 = Store.Commit.v rw ~parents:[] ~info tree in - let* tree = Store.Tree.add tree [ "a"; "b3" ] large_contents in - let* c2 = Store.Commit.v rw ~parents:[ Store.Commit.key c1 ] ~info tree in + let tree = Store.Tree.add tree [ "a"; "b3" ] large_contents in + let c2 = Store.Commit.v rw ~parents:[ Store.Commit.key c1 ] ~info tree in - let* tree = Store.Tree.remove tree [ "a"; "b1"; "c1" ] in - let* c3 = Store.Commit.v rw ~parents:[ Store.Commit.key c2 ] ~info tree in + let tree = Store.Tree.remove tree [ "a"; "b1"; "c1" ] in + let c3 = Store.Commit.v rw ~parents:[ Store.Commit.key c2 ] ~info tree in - let* () = before_closing rw (Store.Commit.key c3) in + let () = before_closing rw (Store.Commit.key c3) in - let* _ = Store.Repo.close rw in + let _ = Store.Repo.close rw in - Lwt.return c3 + c3 let create_gced_store path = let before_closing repo head = - let* _ = Store.Gc.start_exn repo head in - let* _ = Store.Gc.wait repo in - Lwt.return_unit + let _ = Store.Gc.start_exn repo head in + let _ = Store.Gc.wait repo in + () in create_store ~before_closing Irmin_pack.Indexing_strategy.minimal path @@ -86,17 +84,17 @@ let ensure_data_dir () = let generate () = ensure_data_dir (); - let* _ = + let _ = Generator.create_store Irmin_pack.Indexing_strategy.minimal "data/minimal" in - let* _ = + let _ = Generator.create_store Irmin_pack.Indexing_strategy.always "data/always" in - let* _ = Generator.create_gced_store "data/gced" in - let* _ = + let _ = Generator.create_gced_store "data/gced" in + let _ = Generator.create_snapshot_store ~src:"data/snapshot_src" ~dest:"data/snapshot" in - Lwt.return_unit + () -let () = Lwt_main.run (generate ()) +let () = Eio_main.run @@ fun _env -> generate () diff --git a/test/irmin/test_conf.ml b/test/irmin/test_conf.ml index 311bc04cb0..afcd08b7c9 100644 --- a/test/irmin/test_conf.ml +++ b/test/irmin/test_conf.ml @@ -52,7 +52,6 @@ let test_duplicate_key_names () = let suite = [ - Alcotest.test_case_sync "conf" `Quick test_conf; - Alcotest.test_case_sync "duplicate key names" `Quick - test_duplicate_key_names; + Alcotest.test_case "conf" `Quick test_conf; + Alcotest.test_case "duplicate key names" `Quick test_duplicate_key_names; ] diff --git a/test/irmin/test_tree.ml b/test/irmin/test_tree.ml index 2458ccf288..0342ba9a93 100644 --- a/test/irmin/test_tree.ml +++ b/test/irmin/test_tree.ml @@ -462,7 +462,7 @@ let lazy_stats = Tree.{ nodes = 0; leafs = 0; skips = 1; depth = 0; width = 0 } (* Take a tree and persist it to some underlying store, making it lazy. *) let persist_tree ?clear : Store.tree -> Store.tree = fun tree -> - let store = Store.Repo.v (Irmin_mem.config ()) >>= Store.empty in + let store = Store.Repo.v (Irmin_mem.config ()) |> Store.empty in let () = Store.set_tree_exn ?clear ~info:Store.Info.none store [] tree in Store.tree store @@ -517,28 +517,27 @@ let test_clear () = in () -let test_minimal_reads _ () = +let test_minimal_reads () = (* 1. Build a tree *) let size = 10 in - let* t = + let t = List.init size string_of_int - |> Lwt_list.fold_left_s (fun acc i -> Tree.add acc [ i ] i) (Tree.empty ()) + |> List.fold_left (fun acc i -> Tree.add acc [ i ] i) (Tree.empty ()) in (* Persist with no clear *) Tree.reset_counters (); - let* _ = persist_tree ~clear:false t in - let* _ = Tree.find t [ "0" ] in + let _ = persist_tree ~clear:false t in + let _ = Tree.find t [ "0" ] in let cnt = Tree.counters () in Alcotest.(check int) "no reads" 0 cnt.node_find; (* Persist with clear *) Tree.reset_counters (); - let* _ = persist_tree ~clear:true t in - let* _ = Tree.find_tree t [ "0" ] in + let _ = persist_tree ~clear:true t in + let _ = Tree.find_tree t [ "0" ] in let cnt = Tree.counters () in - Alcotest.(check int) "reads" 1 cnt.node_find; - Lwt.return_unit + Alcotest.(check int) "reads" 1 cnt.node_find let with_binding k v t = Tree.add_tree t k v From 8fac61199df49021f05fcce45b5bdd21ef7d728a Mon Sep 17 00:00:00 2001 From: ArthurW Date: Wed, 31 May 2023 20:38:43 +0200 Subject: [PATCH 16/99] Fix irmin-pack bench --- bench/irmin-pack/bench_common.ml | 16 +-- bench/irmin-pack/bench_common.mli | 2 + bench/irmin-pack/dune | 8 +- bench/irmin-pack/import.ml | 11 ++ bench/irmin-pack/trace_collection.ml | 18 ++- bench/irmin-pack/trace_replay.ml | 75 ++++++------ bench/irmin-pack/trace_replay_intf.ml | 17 +-- bench/irmin-pack/trace_stat_summary_utils.ml | 2 +- bench/irmin-pack/tree.ml | 113 +++++++++---------- src/irmin-pack/unix/store.ml | 2 - test/irmin-bench/dune | 1 + test/irmin-bench/replay.ml | 40 ++++--- test/irmin-bench/test.ml | 1 + test/irmin-pack/test_gc.ml | 26 ++--- test/irmin-pack/test_tree.ml | 2 +- 15 files changed, 163 insertions(+), 171 deletions(-) diff --git a/bench/irmin-pack/bench_common.ml b/bench/irmin-pack/bench_common.ml index c2c01d11cb..771ce98df2 100644 --- a/bench/irmin-pack/bench_common.ml +++ b/bench/irmin-pack/bench_common.ml @@ -14,7 +14,7 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Irmin.Export_for_backends +module Mtime = Import.Mtime let c0 = Mtime_clock.counter () let now_us () = Mtime.span_to_us (Mtime_clock.count c0) @@ -77,7 +77,7 @@ let prepare_artefacts_dir path = let with_timer f = let t0 = Sys.time () in - let+ a = f () in + let a = f () in let t1 = Sys.time () -. t0 in (t1, a) @@ -163,19 +163,19 @@ struct let add_chain_trees depth nb tree = let path = key 2 in let rec aux i tree = - if i >= nb then Lwt.return tree + if i >= nb then tree else - let* tree = chain_tree tree depth path in + let tree = chain_tree tree depth path in aux (i + 1) tree in aux 0 tree let large_tree path tree width = let rec aux i tree = - if i >= width then Lwt.return tree + if i >= width then tree else let k = path @ [ random_key () ] in - let* tree = Store.Tree.add tree k (random_blob ()) in + let tree = Store.Tree.add tree k (random_blob ()) in aux (i + 1) tree in aux 0 tree @@ -183,10 +183,10 @@ struct let add_large_trees width nb tree = let path = key 1 in let rec aux i tree = - if i >= nb then Lwt.return tree + if i >= nb then tree else let path = path @ [ random_key () ] in - let* tree = large_tree path tree width in + let tree = large_tree path tree width in aux (i + 1) tree in aux 0 tree diff --git a/bench/irmin-pack/bench_common.mli b/bench/irmin-pack/bench_common.mli index 60bf61224e..57f247bbf3 100644 --- a/bench/irmin-pack/bench_common.mli +++ b/bench/irmin-pack/bench_common.mli @@ -14,6 +14,8 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) +module Mtime : module type of Import.Mtime + val default_artefacts_dir : string val prepare_artefacts_dir : string -> unit val reporter : ?prefix:string -> unit -> Logs.reporter diff --git a/bench/irmin-pack/dune b/bench/irmin-pack/dune index 36ae897f1c..487bb2cbff 100644 --- a/bench/irmin-pack/dune +++ b/bench/irmin-pack/dune @@ -8,7 +8,6 @@ (libraries irmin-pack irmin-test.bench - lwt unix cmdliner logs @@ -21,7 +20,7 @@ (library (name bench_common) (public_name irmin-bench.common) - (modules bench_common) + (modules bench_common import) (libraries irmin-pack irmin-pack.unix irmin-tezos unix progress uuidm) (preprocess (pps ppx_irmin.internal)) @@ -42,15 +41,13 @@ trace_replay trace_replay_intf tezos_history_metrics - trace_stat_summary_cb - import) + trace_stat_summary_cb) (preprocess (pps ppx_irmin.internal ppx_repr ppx_deriving.enum)) (libraries irmin irmin-pack unix - lwt repr ppx_repr bentov @@ -71,7 +68,6 @@ irmin-pack irmin-pack.mem irmin-test.bench - lwt unix cmdliner logs diff --git a/bench/irmin-pack/import.ml b/bench/irmin-pack/import.ml index 2fed488f98..138e7f191f 100644 --- a/bench/irmin-pack/import.ml +++ b/bench/irmin-pack/import.ml @@ -15,3 +15,14 @@ *) include Irmin.Export_for_backends + +module Mtime = struct + include Mtime + + module Span = struct + include Mtime.Span + + let to_s span = Mtime.Span.to_float_ns span *. 1e-9 + let to_us span = Mtime.Span.to_float_ns span *. 1e-3 + end +end diff --git a/bench/irmin-pack/trace_collection.ml b/bench/irmin-pack/trace_collection.ml index 94a51eed8b..fcd1bc6be5 100644 --- a/bench/irmin-pack/trace_collection.ml +++ b/bench/irmin-pack/trace_collection.ml @@ -21,8 +21,7 @@ A module [Make_replayable] has yet to be implemented. *) -open Lwt.Syntax -module Mtime = Import.Mtime +module Mtime = Bench_common.Mtime (** Make state trace collector. *) module Make_stat (Store : Irmin.Generic_key.KV) = struct @@ -201,8 +200,7 @@ module Make_stat (Store : Irmin.Generic_key.KV) = struct let short_op_end { t0; writer; _ } short_op = let duration = - Mtime_clock.count t0 |> fun span -> - Mtime.span_to_s span |> Int32.bits_of_float + Mtime_clock.count t0 |> Mtime.span_to_s |> Int32.bits_of_float in let op = match short_op with @@ -217,18 +215,18 @@ module Make_stat (Store : Irmin.Generic_key.KV) = struct Def.append_row writer op let create_store_before tree = - let+ Store.Tree.{ nodes; leafs; skips; depth; width } = + let Store.Tree.{ nodes; leafs; skips; depth; width } = Store.Tree.stats ~force:false tree in Def.{ nodes; leafs; skips; depth; width } let create_store_after tree = - let* watched_nodes_length = - Lwt_list.map_s + let watched_nodes_length = + List.map (fun (_, steps) -> Store.Tree.length tree steps) Def.step_list_per_watched_node in - Lwt.return Def.{ watched_nodes_length } + Def.{ watched_nodes_length } let commit_begin t tree = short_op_begin t; @@ -236,7 +234,7 @@ module Make_stat (Store : Irmin.Generic_key.KV) = struct Bag_of_stats.create t.store_path t.prev_merge_durations in t.prev_merge_durations <- Index.Stats.((get ()).merge_durations); - let+ store_before = create_store_before tree in + let store_before = create_store_before tree in t.commit_before <- (stats_before, store_before) let commit_end t tree = @@ -244,7 +242,7 @@ module Make_stat (Store : Irmin.Generic_key.KV) = struct let duration = duration |> Int32.bits_of_float in let stats_after = Bag_of_stats.create t.store_path t.prev_merge_durations in t.prev_merge_durations <- Index.Stats.((get ()).merge_durations); - let+ store_after = create_store_after tree in + let store_after = create_store_after tree in let op = `Commit Def. diff --git a/bench/irmin-pack/trace_replay.ml b/bench/irmin-pack/trace_replay.ml index e0bed82ebc..11eabd8c35 100644 --- a/bench/irmin-pack/trace_replay.ml +++ b/bench/irmin-pack/trace_replay.ml @@ -185,7 +185,7 @@ module Make (Store : Store) = struct let h_store = Hashtbl.find t.hash_corresps (unscope h_trace) in maybe_forget_hash t h_trace; Stat_collector.short_op_begin stats; - Store.Commit.of_key repo h_store >|= function + match Store.Commit.of_key repo h_store with | None -> failwith "prev commit not found" | Some commit -> let tree = Store.Commit.tree commit in @@ -198,7 +198,7 @@ module Make (Store : Store) = struct let { tree } = Hashtbl.find t.contexts (unscope in_ctx_id) in maybe_forget_ctx t in_ctx_id; Stat_collector.short_op_begin stats; - let+ tree = Store.Tree.add tree key v in + let tree = Store.Tree.add tree key v in Stat_collector.short_op_end stats `Add; Hashtbl.add t.contexts (unscope out_ctx_id) { tree }; maybe_forget_ctx t out_ctx_id @@ -207,7 +207,7 @@ module Make (Store : Store) = struct let { tree } = Hashtbl.find t.contexts (unscope in_ctx_id) in maybe_forget_ctx t in_ctx_id; Stat_collector.short_op_begin stats; - let+ tree = Store.Tree.remove tree keys in + let tree = Store.Tree.remove tree keys in Stat_collector.short_op_end stats `Remove; Hashtbl.add t.contexts (unscope out_ctx_id) { tree }; maybe_forget_ctx t out_ctx_id @@ -216,20 +216,19 @@ module Make (Store : Store) = struct let { tree } = Hashtbl.find t.contexts (unscope in_ctx_id) in maybe_forget_ctx t in_ctx_id; Stat_collector.short_op_begin stats; - Store.Tree.find_tree tree from >>= function + match Store.Tree.find_tree tree from with | None -> failwith "Couldn't find tree in exec_copy" | Some sub_tree -> - let* tree = Store.Tree.add_tree tree to_ sub_tree in + let tree = Store.Tree.add_tree tree to_ sub_tree in Stat_collector.short_op_end stats `Copy; Hashtbl.add t.contexts (unscope out_ctx_id) { tree }; - maybe_forget_ctx t out_ctx_id; - Lwt.return_unit + maybe_forget_ctx t out_ctx_id let exec_find t stats n i keys b in_ctx_id = let { tree } = Hashtbl.find t.contexts (unscope in_ctx_id) in maybe_forget_ctx t in_ctx_id; Stat_collector.short_op_begin stats; - let+ query = Store.Tree.find tree keys in + let query = Store.Tree.find tree keys in Stat_collector.short_op_end stats `Find; if Option.is_some query <> b then error_find "find" keys b i n (unscope in_ctx_id) @@ -238,7 +237,7 @@ module Make (Store : Store) = struct let { tree } = Hashtbl.find t.contexts (unscope in_ctx_id) in maybe_forget_ctx t in_ctx_id; Stat_collector.short_op_begin stats; - let+ b' = Store.Tree.mem tree keys in + let b' = Store.Tree.mem tree keys in Stat_collector.short_op_end stats `Mem; if b <> b' then error_find "mem" keys b i n (unscope in_ctx_id) @@ -246,7 +245,7 @@ module Make (Store : Store) = struct let { tree } = Hashtbl.find t.contexts (unscope in_ctx_id) in maybe_forget_ctx t in_ctx_id; Stat_collector.short_op_begin stats; - let+ b' = Store.Tree.mem_tree tree keys in + let b' = Store.Tree.mem_tree tree keys in Stat_collector.short_op_end stats `Mem_tree; if b <> b' then error_find "mem_tree" keys b i n (unscope in_ctx_id) @@ -265,14 +264,14 @@ module Make (Store : Store) = struct List.iter (maybe_forget_hash t) parents_trace; let { tree } = Hashtbl.find t.contexts (unscope in_ctx_id) in maybe_forget_ctx t in_ctx_id; - let* () = Stat_collector.commit_begin stats tree in - let* _ = + let () = Stat_collector.commit_begin stats tree in + let _ = (* in tezos commits call Tree.list first for the unshallow operation *) Store.Tree.list tree [] in let info = Store.Info.v ~author:"Tezos" ~message date in - let* commit = Store.Commit.v repo ~info ~parents:parents_store tree in - let+ () = Stat_collector.commit_end stats tree in + let commit = Store.Commit.v repo ~info ~parents:parents_store tree in + let () = Stat_collector.commit_end stats tree in Store.Tree.clear tree; let k_store, h_store = Store.Commit.(key commit, hash commit) in if check_hash then check_hash_trace (unscope h_trace) h_store; @@ -290,30 +289,30 @@ module Make (Store : Store) = struct let rec aux l i = match l with | Def.Checkout (h, out_ctx_id) :: tl -> - let* () = exec_checkout t stats repo h out_ctx_id in + let () = exec_checkout t stats repo h out_ctx_id in aux tl (i + 1) | Add op :: tl -> - let* () = + let () = exec_add t stats op.key op.value op.in_ctx_id op.out_ctx_id empty_blobs in aux tl (i + 1) | Remove (keys, in_ctx_id, out_ctx_id) :: tl -> - let* () = exec_remove t stats keys in_ctx_id out_ctx_id in + let () = exec_remove t stats keys in_ctx_id out_ctx_id in aux tl (i + 1) | Copy op :: tl -> - let* () = + let () = exec_copy t stats op.key_src op.key_dst op.in_ctx_id op.out_ctx_id in aux tl (i + 1) | Find (keys, b, in_ctx_id) :: tl -> - let* () = exec_find t stats n i keys b in_ctx_id in + let () = exec_find t stats n i keys b in_ctx_id in aux tl (i + 1) | Mem (keys, b, in_ctx_id) :: tl -> - let* () = exec_mem t stats n i keys b in_ctx_id in + let () = exec_mem t stats n i keys b in_ctx_id in aux tl (i + 1) | Mem_tree (keys, b, in_ctx_id) :: tl -> - let* () = exec_mem_tree t stats n i keys b in_ctx_id in + let () = exec_mem_tree t stats n i keys b in_ctx_id in aux tl (i + 1) | [ Commit op ] -> exec_commit t stats repo op.hash op.date op.message op.parents @@ -392,7 +391,9 @@ module Make (Store : Store) = struct let rec aux commit_seq i = match commit_seq () with - | Seq.Nil -> on_end () >|= fun () -> i + | Seq.Nil -> + on_end (); + i | Cons (ops, commit_seq) -> let really_wait_gc, really_start_gc, really_split, really_add_volume = gc_actions config i t.commits_since_start_or_gc t.gc_count @@ -400,14 +401,13 @@ module Make (Store : Store) = struct (* Split before GC to simulate how it is inteded to be used. *) let () = if really_split then Store.split repo in let () = if really_add_volume then Store.add_volume repo in - let* () = + let () = if really_wait_gc then ( [%logs.app "Waiting gc while latest commit has idx %d" t.latest_commit_idx]; Store.gc_wait repo) - else Lwt.return_unit in - let* () = + let () = if really_start_gc then ( (* Starting GC. @@ -441,14 +441,12 @@ module Make (Store : Store) = struct [%logs.app "Gc ended after %d commits; duration: %fs; \ finalise_duration: %fs" - commit_duration duration finalise_duration]; - Lwt.return_unit + commit_duration duration finalise_duration] | Error s -> failwith s in Store.gc_run ~finished repo gc_commit_key) - else Lwt.return_unit in - let* () = add_operations t repo ops i stats check_hash empty_blobs in + let () = add_operations t repo ops i stats check_hash empty_blobs in t.latest_commit_idx <- i; let len0 = Hashtbl.length t.contexts in let len1 = Hashtbl.length t.hash_corresps in @@ -456,7 +454,7 @@ module Make (Store : Store) = struct [%logs.app "\nAfter commit %6d we have %d/%d history sizes" t.latest_commit_idx len0 len1]; - let* () = + let () = on_commit t.latest_commit_idx (Hashtbl.find t.key_per_commit_idx t.latest_commit_idx |> Store.Backend.Commit.Key.to_hash) @@ -467,7 +465,7 @@ module Make (Store : Store) = struct in aux commit_seq 0 - let run : type a. _ -> a config -> a Lwt.t = + let run : type a. _ -> a config -> a = fun ext_config config -> let check_hash = config.path_conversion = `None @@ -482,7 +480,7 @@ module Make (Store : Store) = struct config.path_conversion config.replay_trace_path in let root = Filename.concat config.artefacts_path "root" in - let* repo, on_commit, on_end = Store.create_repo ~root ext_config in + let repo, on_commit, on_end = Store.create_repo ~root ext_config in prepare_artefacts_dir config.artefacts_path; let stat_path = Filename.concat config.artefacts_path "stat_trace.repr" in let c = @@ -501,24 +499,23 @@ module Make (Store : Store) = struct in let stats = Stat_collector.create_file stat_path c root in Irmin_pack.Stats.reset_stats (); - Lwt.finalize + Fun.protect (fun () -> - let* block_count = + let block_count = add_commits config repo commit_seq on_commit on_end stats check_hash config.empty_blobs in [%logs.app "Closing repo..."]; - let+ () = Store.Repo.close repo in + let () = Store.Repo.close repo in Stat_collector.close stats; match config.return_type with | Unit -> (() : a) | Summary -> [%logs.app "Computing summary..."]; Trace_stat_summary.summarise ~block_count stat_path) - (fun () -> + ~finally:(fun () -> if config.keep_stat_trace then ( [%logs.app "Stat trace kept at %s" stat_path]; - Unix.chmod stat_path 0o444; - Lwt.return_unit) - else Lwt.return (Stat_collector.remove stats)) + Unix.chmod stat_path 0o444) + else Stat_collector.remove stats) end diff --git a/bench/irmin-pack/trace_replay_intf.ml b/bench/irmin-pack/trace_replay_intf.ml index 93d558d2be..76ca74d211 100644 --- a/bench/irmin-pack/trace_replay_intf.ml +++ b/bench/irmin-pack/trace_replay_intf.ml @@ -96,23 +96,18 @@ module type Store = sig and type node_key = key and type contents_key = key - type on_commit := int -> Hash.t -> unit Lwt.t - type on_end := unit -> unit Lwt.t - - val create_repo : - root:string -> store_config -> (Repo.t * on_commit * on_end) Lwt.t + type on_commit := int -> Hash.t -> unit + type on_end := unit -> unit + val create_repo : root:string -> store_config -> Repo.t * on_commit * on_end val split : repo -> unit val add_volume : repo -> unit - val gc_wait : repo -> unit Lwt.t + val gc_wait : repo -> unit type stats := Irmin_pack_unix.Stats.Latest_gc.stats val gc_run : - ?finished:((stats, string) result -> unit Lwt.t) -> - repo -> - commit_key -> - unit Lwt.t + ?finished:((stats, string) result -> unit) -> repo -> commit_key -> unit end module type Sigs = sig @@ -129,6 +124,6 @@ module type Sigs = sig with type 'a return_type = 'a return_type and type 'a config = 'a config - val run : Store.store_config -> 'a config -> 'a Lwt.t + val run : Store.store_config -> 'a config -> 'a end end diff --git a/bench/irmin-pack/trace_stat_summary_utils.ml b/bench/irmin-pack/trace_stat_summary_utils.ml index 8e109b1144..144aa6509f 100644 --- a/bench/irmin-pack/trace_stat_summary_utils.ml +++ b/bench/irmin-pack/trace_stat_summary_utils.ml @@ -90,7 +90,7 @@ let create_pp_seconds examples = let finite_pp = if absmax >= 60. then fun ppf v -> Fmt.uint64_ns_span ppf (Int64.of_float v) else if absmax < 100. *. 1e-12 then fun ppf v -> - Format.fprintf ppf "%.3e s" v + Format.fprintf ppf "%.3f s" v else if absmax < 100. *. 1e-9 then fun ppf v -> Format.fprintf ppf "%.3f ns" (v *. 1e9) else if absmax < 100. *. 1e-6 then fun ppf v -> diff --git a/bench/irmin-pack/tree.ml b/bench/irmin-pack/tree.ml index 4430fe45a9..e087cc6b6e 100644 --- a/bench/irmin-pack/tree.ml +++ b/bench/irmin-pack/tree.ml @@ -53,11 +53,10 @@ module type Store = sig and type node_key = key and type contents_key = key - type on_commit := int -> Hash.t -> unit Lwt.t - type on_end := unit -> unit Lwt.t + type on_commit := int -> Hash.t -> unit + type on_end := unit -> unit - val create_repo : - root:string -> store_config -> (Repo.t * on_commit * on_end) Lwt.t + val create_repo : root:string -> store_config -> Repo.t * on_commit * on_end type stats := Irmin_pack_unix.Stats.Latest_gc.stats @@ -65,12 +64,9 @@ module type Store = sig val add_volume : repo -> unit val gc_run : - ?finished:((stats, string) result -> unit Lwt.t) -> - repo -> - commit_key -> - unit Lwt.t + ?finished:((stats, string) result -> unit) -> repo -> commit_key -> unit - val gc_wait : repo -> unit Lwt.t + val gc_wait : repo -> unit end let pp_inode_config ppf (entries, stable_hash) = @@ -84,7 +80,7 @@ module Benchmark = struct type result = { time : float; size : int } let run config f = - let+ time, res = with_timer f in + let time, res = with_timer f in let size = FSHelper.get_size config.store_dir in ({ time; size }, res) @@ -103,15 +99,15 @@ module Bench_suite (Store : Store) = struct match prev_commit with | None -> let tree = Store.Tree.empty () in - let* tree = f tree in + let tree = f tree in Store.Commit.v repo ~info:(Info.f ()) ~parents:[] tree | Some prev_commit -> ( let prev_commit = Store.Commit.key prev_commit in - Store.Commit.of_key repo prev_commit >>= function - | None -> Lwt.fail_with "commit not found" + match Store.Commit.of_key repo prev_commit with + | None -> failwith "commit not found" | Some commit -> let tree = Store.Commit.tree commit in - let* tree = f tree in + let tree = f tree in Store.Commit.v repo ~info:(Info.f ()) ~parents:[ prev_commit ] tree) let add_commits ~message repo ncommits on_commit on_end f () = @@ -119,8 +115,8 @@ module Bench_suite (Store : Store) = struct let rec aux c i = if i >= ncommits then on_end () else - let* c' = checkout_and_commit repo c f in - let* () = on_commit i (Store.Commit.hash c') in + let c' = checkout_and_commit repo c f in + let () = on_commit i (Store.Commit.hash c') in prog 1; aux (Some c') (i + 1) in @@ -129,14 +125,14 @@ module Bench_suite (Store : Store) = struct let run_large config = reset_stats (); let root = config.store_dir in - let* repo, on_commit, on_end = Store.create_repo ~root config in - let* result, () = + let repo, on_commit, on_end = Store.create_repo ~root config in + let result, () = Trees.add_large_trees config.width config.nlarge_trees |> add_commits ~message:"Playing large mode" repo config.ncommits on_commit on_end |> Benchmark.run config in - let+ () = Store.Repo.close repo in + let () = Store.Repo.close repo in fun ppf -> Format.fprintf ppf "Large trees mode on inode config %a, %a: %d commits, each consisting \ @@ -149,14 +145,14 @@ module Bench_suite (Store : Store) = struct let run_chains config = reset_stats (); let root = config.store_dir in - let* repo, on_commit, on_end = Store.create_repo ~root config in - let* result, () = + let repo, on_commit, on_end = Store.create_repo ~root config in + let result, () = Trees.add_chain_trees config.depth config.nchain_trees |> add_commits ~message:"Playing chain mode" repo config.ncommits on_commit on_end |> Benchmark.run config in - let+ () = Store.Repo.close repo in + let () = Store.Repo.close repo in fun ppf -> Format.fprintf ppf "Chain trees mode on inode config %a, %a: %d commits, each consisting \ @@ -187,12 +183,12 @@ module Bench_suite (Store : Store) = struct } in if config.no_summary then - let+ () = + let () = Trace_replay.run config { replay_config with return_type = Unit } in fun _ppf -> () else - let+ summary = Trace_replay.run config replay_config in + let summary = Trace_replay.run config replay_config in fun ppf -> if not config.no_summary then ( let p = Filename.concat config.artefacts_path "stat_summary.json" in @@ -221,15 +217,15 @@ module Make_store_mem (Conf : Irmin_pack.Conf.S) = struct Irmin_pack.config ~readonly:false ~fresh:true ~indexing_strategy root in prepare_artefacts_dir root; - let* repo = Store.Repo.v conf in - let on_commit _ _ = Lwt.return_unit in - let on_end () = Lwt.return_unit in - Lwt.return (repo, on_commit, on_end) + let repo = Store.Repo.v conf in + let on_commit _ _ = () in + let on_end () = () in + (repo, on_commit, on_end) let split _repo = () let add_volume _repo = () - let gc_wait _repo = Lwt.return_unit - let gc_run ?finished:_ _repo _key = Lwt.return_unit + let gc_wait _repo = () + let gc_run ?finished:_ _repo _key = () end module Make_store_pack (Conf : Irmin_pack.Conf.S) = struct @@ -256,35 +252,35 @@ module Make_store_pack (Conf : Irmin_pack.Conf.S) = struct ~lower_root root in prepare_artefacts_dir root; - let* repo = Store.Repo.v conf in - let on_commit _ _ = Lwt.return_unit in - let on_end () = Lwt.return_unit in - Lwt.return (repo, on_commit, on_end) + let repo = Store.Repo.v conf in + let on_commit _ _ = () in + let on_end () = () in + (repo, on_commit, on_end) let split = Store.split let add_volume = Store.add_volume let gc_wait repo = - let* r = Store.Gc.wait repo in - match r with Ok _ -> Lwt.return_unit | Error (`Msg err) -> failwith err + let r = Store.Gc.wait repo in + match r with Ok _ -> () | Error (`Msg err) -> failwith err - let gc_run ?(finished = fun _ -> Lwt.return_unit) repo key = + let gc_run ?(finished = fun _ -> ()) repo key = let f (result : (_, Store.Gc.msg) result) = match result with | Error (`Msg err) -> finished @@ Error err | Ok stats -> finished @@ Ok stats in - let* launched = Store.Gc.run ~finished:f repo key in + let launched = Store.Gc.run ~finished:f repo key in match launched with - | Ok true -> Lwt.return_unit - | Ok false -> [%logs.app "GC skipped"] |> Lwt.return + | Ok true -> () + | Ok false -> [%logs.app "GC skipped"] | Error (`Msg err) -> failwith err end module type B = sig - val run_large : config -> (Format.formatter -> unit) Lwt.t - val run_chains : config -> (Format.formatter -> unit) Lwt.t - val run_read_trace : config -> (Format.formatter -> unit) Lwt.t + val run_large : config -> Format.formatter -> unit + val run_chains : config -> Format.formatter -> unit + val run_read_trace : config -> Format.formatter -> unit end let store_of_config config = @@ -302,7 +298,7 @@ let store_of_config config = type suite_elt = { mode : [ `Read_trace | `Chains | `Large ]; speed : [ `Quick | `Slow | `Custom ]; - run : config -> (Format.formatter -> unit) Lwt.t; + run : config -> Format.formatter -> unit; } let suite : suite_elt list = @@ -443,22 +439,21 @@ let main () ncommits number_of_commits_to_replay suite_filter inode_config Gc.set { (Gc.get ()) with Gc.allocation_policy = 0 }; FSHelper.rm_dir config.store_dir; let suite = get_suite suite_filter in - let run_benchmarks () = Lwt_list.map_s (fun b -> b.run config) suite in + let run_benchmarks () = List.map (fun b -> b.run config) suite in let results = - Lwt_main.run - (Lwt.finalize run_benchmarks (fun () -> - if keep_store then ( - [%logs.app "Store kept at %s" config.store_dir]; - let ( / ) = Filename.concat in - let ro p = if Sys.file_exists p then Unix.chmod p 0o444 in - ro (config.store_dir / "store.branches"); - ro (config.store_dir / "store.dict"); - ro (config.store_dir / "store.pack"); - ro (config.store_dir / "index" / "data"); - ro (config.store_dir / "index" / "log"); - ro (config.store_dir / "index" / "log_async")) - else FSHelper.rm_dir config.store_dir; - Lwt.return_unit)) + Eio_main.run @@ fun _env -> + Fun.protect run_benchmarks ~finally:(fun () -> + if keep_store then ( + [%logs.app "Store kept at %s" config.store_dir]; + let ( / ) = Filename.concat in + let ro p = if Sys.file_exists p then Unix.chmod p 0o444 in + ro (config.store_dir / "store.branches"); + ro (config.store_dir / "store.dict"); + ro (config.store_dir / "store.pack"); + ro (config.store_dir / "index" / "data"); + ro (config.store_dir / "index" / "log"); + ro (config.store_dir / "index" / "log_async")) + else FSHelper.rm_dir config.store_dir) in [%logs.app "%a@." Fmt.(list ~sep:(any "@\n@\n") (fun ppf f -> f ppf)) results] diff --git a/src/irmin-pack/unix/store.ml b/src/irmin-pack/unix/store.ml index 73dfe9f4d9..41303dfa8b 100644 --- a/src/irmin-pack/unix/store.ml +++ b/src/irmin-pack/unix/store.ml @@ -17,8 +17,6 @@ open! Import include Store_intf -let ( let* ) = Result.bind - module Maker (Config : Conf.S) = struct type endpoint = unit diff --git a/test/irmin-bench/dune b/test/irmin-bench/dune index 643ec4038a..e356599980 100644 --- a/test/irmin-bench/dune +++ b/test/irmin-bench/dune @@ -2,6 +2,7 @@ (name test) (libraries alcotest + eio_main irmin_traces fpath irmin-tezos diff --git a/test/irmin-bench/replay.ml b/test/irmin-bench/replay.ml index 65495fc5ab..d59704705d 100644 --- a/test/irmin-bench/replay.ml +++ b/test/irmin-bench/replay.ml @@ -24,25 +24,25 @@ module Store = struct | true -> () in let conf = Irmin_pack.config ~readonly:false ~fresh:true root in - let* repo = Store.Repo.v conf in - let on_commit _ _ = Lwt.return_unit in - let on_end () = Lwt.return_unit in - Lwt.return (repo, on_commit, on_end) + let repo = Store.Repo.v conf in + let on_commit _ _ = () in + let on_end () = () in + (repo, on_commit, on_end) let gc_wait repo = - let* r = Store.Gc.wait repo in - match r with Ok _ -> Lwt.return_unit | Error (`Msg err) -> failwith err + let r = Store.Gc.wait repo in + match r with Ok _ -> () | Error (`Msg err) -> failwith err - let gc_run ?(finished = fun _ -> Lwt.return_unit) repo key = + let gc_run ?(finished = fun _ -> ()) repo key = let f (result : (_, Store.Gc.msg) result) = match result with | Error (`Msg err) -> finished @@ Error err | Ok stats -> finished @@ Ok stats in - let* launched = Store.Gc.run ~finished:f repo key in + let launched = Store.Gc.run ~finished:f repo key in match launched with - | Ok true -> Lwt.return_unit - | Ok false -> [%logs.app "GC skipped"] |> Lwt.return + | Ok true -> () + | Ok false -> [%logs.app "GC skipped"] | Error (`Msg err) -> failwith err end @@ -98,7 +98,7 @@ let replay_1_commit () = add_volume_every = 0; } in - let+ summary = Replay.run () replay_config in + let summary = Replay.run () replay_config in [%logs.debug "%a" (Irmin_traces.Trace_stat_summary_pp.pp 5) ([ "" ], [ summary ])]; let check name = Alcotest.(check int) ("Stats_counters" ^ name) in @@ -136,15 +136,15 @@ module Store_mem = struct let create_repo ~root () = let conf = Irmin_pack.config ~readonly:false ~fresh:true root in - let* repo = Store.Repo.v conf in - let on_commit _ _ = Lwt.return_unit in - let on_end () = Lwt.return_unit in - Lwt.return (repo, on_commit, on_end) + let repo = Store.Repo.v conf in + let on_commit _ _ = () in + let on_end () = () in + (repo, on_commit, on_end) let split _repo = () let add_volume _repo = () - let gc_wait _repo = Lwt.return_unit - let gc_run ?finished:_ _repo _key = Lwt.return_unit + let gc_wait _repo = () + let gc_run ?finished:_ _repo _key = () end module Replay_mem = Irmin_traces.Trace_replay.Make (Store_mem) @@ -169,15 +169,13 @@ let replay_1_commit_mem () = add_volume_every = 0; } in - let+ summary = Replay_mem.run () replay_config in + let summary = Replay_mem.run () replay_config in [%logs.debug "%a" (Irmin_traces.Trace_stat_summary_pp.pp 5) ([ "" ], [ summary ])]; () let test_cases = - let tc msg f = - Alcotest.test_case msg `Quick (fun () -> Lwt_main.run (f ())) - in + let tc msg f = Alcotest.test_case msg `Quick f in [ ( "replay", [ diff --git a/test/irmin-bench/test.ml b/test/irmin-bench/test.ml index 3d09831eaf..4afc178092 100644 --- a/test/irmin-bench/test.ml +++ b/test/irmin-bench/test.ml @@ -15,5 +15,6 @@ *) let () = + Eio_main.run @@ fun _env -> Alcotest.run "irmin-bench" (Ema.test_cases @ Misc.test_cases @ Replay.test_cases) diff --git a/test/irmin-pack/test_gc.ml b/test/irmin-pack/test_gc.ml index 4de4b71774..5e6081890d 100644 --- a/test/irmin-pack/test_gc.ml +++ b/test/irmin-pack/test_gc.ml @@ -1466,21 +1466,21 @@ module Snapshot = struct the last gc target commit (ie it is in the lower) *) let snapshot_gced_commit () = let lower_root = create_lower_root ~mkdir:false () in - let* t = init ~lower_root:(Some lower_root) () in - let* t, c1 = commit_1 t in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in - let* () = start_gc t c2 in - let* () = finalise_gc t in + let t = init ~lower_root:(Some lower_root) () in + let t, c1 = commit_1 t in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in + let () = start_gc t c2 in + let () = finalise_gc t in let root_snap = Filename.concat t.root "snap" in - let* () = export t c1 root_snap in - let* () = S.Repo.close t.repo in + let () = export t c1 root_snap in + let () = S.Repo.close t.repo in [%log.debug "open store from snapshot"]; - let* t = init ~readonly:false ~fresh:false ~root:root_snap () in - let* t = checkout_exn t c1 in - let* t, c2 = commit_2 t in - let* () = check_1 t c1 in - let* () = check_2 t c2 in + let t = init ~readonly:false ~fresh:false ~root:root_snap () in + let t = checkout_exn t c1 in + let t, c2 = commit_2 t in + let () = check_1 t c1 in + let () = check_2 t c2 in S.Repo.close t.repo let tests = diff --git a/test/irmin-pack/test_tree.ml b/test/irmin-pack/test_tree.ml index 761b2ca1b3..1db4f9838d 100644 --- a/test/irmin-pack/test_tree.ml +++ b/test/irmin-pack/test_tree.ml @@ -87,7 +87,7 @@ module Make (Conf : Irmin_pack.Conf.S) = struct | Find k -> find tree k | Find_tree k -> find_tree tree k | Length (k, len_expected) -> - let+ len_tree = Tree.length tree k in + let len_tree = Tree.length tree k in Alcotest.(check int) (Fmt.str "expected tree length at %a" Fmt.(Dump.list string) k) len_expected len_tree; From 96af869fa613cb43e186bb3b43a8fcb8befa26fb Mon Sep 17 00:00:00 2001 From: ArthurW Date: Wed, 31 May 2023 20:41:56 +0200 Subject: [PATCH 17/99] Fix irmin-pack examples --- examples/irmin-pack/dune | 2 +- examples/irmin-pack/gc.ml | 41 ++++++++++++++++++--------------------- examples/irmin-pack/kv.ml | 15 +++++++------- 3 files changed, 27 insertions(+), 31 deletions(-) diff --git a/examples/irmin-pack/dune b/examples/irmin-pack/dune index b054502f19..cd142f6a10 100644 --- a/examples/irmin-pack/dune +++ b/examples/irmin-pack/dune @@ -1,3 +1,3 @@ (executables (names gc kv) - (libraries irmin irmin.unix irmin-pack.unix logs)) + (libraries irmin irmin.unix irmin-pack.unix logs eio_main)) diff --git a/examples/irmin-pack/gc.ml b/examples/irmin-pack/gc.ml index c6282f5a49..0e92f851ef 100644 --- a/examples/irmin-pack/gc.ml +++ b/examples/irmin-pack/gc.ml @@ -122,12 +122,12 @@ end (** Demonstrate running GC on a previous commit aligned to the end of a chunk for ideal GC space reclamation. *) let run_gc config repo tracker = - let* () = + let () = match Tracker.(tracker.next_gc_commit) with - | None -> Lwt.return_unit + | None -> () | Some commit -> ( let finished = function - | Ok stats -> + | Ok stats -> ( let duration = Irmin_pack_unix.Stats.Latest_gc.total_duration stats in @@ -139,17 +139,16 @@ let run_gc config repo tracker = %.2fMB." duration finalise_duration (megabytes_of_path @@ Irmin_pack.Conf.root config); - (match Irmin_pack.Conf.lower_root config with + match Irmin_pack.Conf.lower_root config with | None -> Printf.printf "\n%!" | Some lower -> Printf.printf " Size of lower layer: %.2fMB.\n" - (megabytes_of_path lower)); - Lwt.return_unit - | Error (`Msg err) -> print_endline err |> Lwt.return + (megabytes_of_path lower)) + | Error (`Msg err) -> print_endline err in (* Launch GC *) let commit_key = Store.Commit.key commit in - let+ launched = Store.Gc.run ~finished repo commit_key in + let launched = Store.Gc.run ~finished repo commit_key in match launched with | Ok false -> () | Ok true -> @@ -159,38 +158,36 @@ let run_gc config repo tracker = in (* Create new split and mark the latest commit to be the next GC commit. *) let () = Store.split repo in - Tracker.mark_next_gc_commit tracker |> Lwt.return + Tracker.mark_next_gc_commit tracker let run_experiment config = let num_of_commits = 200_000 in let gc_every = 1_000 in - let* repo = Store.Repo.v config in + let repo = Store.Repo.v config in let tracker = Tracker.v () in (* Create commits *) - let* _ = + let _ = let rec loop i n = let key = "hello" in let value = Printf.sprintf "packfile%d" i in - let* tree = Store.Tree.add (Tracker.latest_tree tracker) [ key ] value in + let tree = Store.Tree.add (Tracker.latest_tree tracker) [ key ] value in let parents = Tracker.latest_parents tracker in - let* commit = + let commit = Store.Commit.v repo ~info:(info "add %s = %s" key value) ~parents tree in Tracker.update_latest_commit tracker commit; - let* _ = - if i mod gc_every = 0 then run_gc config repo tracker - else Lwt.return_unit - in - if i >= n then Lwt.return_unit else loop (i + 1) n + let _ = if i mod gc_every = 0 then run_gc config repo tracker in + if i >= n then () else loop (i + 1) n in loop 1 num_of_commits in (* A GC may still be running. Wait for GC to finish before ending the process *) - let* _ = Store.Gc.wait repo in - Lwt.return_unit + let _ = Store.Gc.wait repo in + () let () = + Eio_main.run @@ fun _env -> Printf.printf "== RUN 1: deleting discarded data ==\n"; - Lwt_main.run (run_experiment Repo_config.config); + run_experiment Repo_config.config; Printf.printf "== RUN 2: archiving discarded data ==\n"; - Lwt_main.run (run_experiment Repo_config.config_with_lower) + run_experiment Repo_config.config_with_lower diff --git a/examples/irmin-pack/kv.ml b/examples/irmin-pack/kv.ml index 418594fdae..ebf481c4f7 100644 --- a/examples/irmin-pack/kv.ml +++ b/examples/irmin-pack/kv.ml @@ -70,24 +70,22 @@ module Store = StoreMaker.Make (Irmin.Contents.String) let main () = (* Instantiate a repository *) - let* repo = Store.Repo.v Repo_config.config in + let repo = Store.Repo.v Repo_config.config in (* Get the store from the main branch. *) - let* store = Store.main repo in + let store = Store.main repo in (* Set a value. *) - let* () = + let () = Store.set_exn ~info:(fun () -> Store.Info.empty) store [ "hello" ] "irmin-pack.unix!" in (* Get the value *) - let* content = Store.get store [ "hello" ] in + let content = Store.get store [ "hello" ] in - Log.app (fun m -> m "hello: %s" content); - - return () + Log.app (fun m -> m "hello: %s" content) let setup_logs () = Fmt_tty.setup_std_outputs (); @@ -95,5 +93,6 @@ let setup_logs () = Logs.(set_level @@ Some Debug) let () = + Eio_main.run @@ fun _env -> setup_logs (); - Lwt_main.run @@ main () + main () From 536e7eb90de126869909861297e8f13df30fb3c6 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Thu, 1 Jun 2023 17:35:33 +0200 Subject: [PATCH 18/99] Fix irmin-http using lwt_eio --- src/irmin/content_addressable.ml | 21 ++------------------- 1 file changed, 2 insertions(+), 19 deletions(-) diff --git a/src/irmin/content_addressable.ml b/src/irmin/content_addressable.ml index b9bfd39c1c..b828b6bd52 100644 --- a/src/irmin/content_addressable.ml +++ b/src/irmin/content_addressable.ml @@ -35,23 +35,7 @@ module Make (AO : Append_only.Maker) (K : Hash.S) (V : Type.S) = struct Fmt.kstr invalid_arg "corrupted value: got %a, expecting %a" pp_key k' pp_key k - let add t v = - check_not_closed t; - S.add t.t v - - let unsafe_add t k v = - check_not_closed t; - S.unsafe_add t.t k v - - let v ?ctx uri item items = - let t = S.v ?ctx uri item items in - { closed = ref false; t } - - let close t = - if !(t.closed) then Lwt.return_unit - else ( - t.closed := true; - S.close t.t) + let unsafe_add t k v = add t k v let add t v = let k = hash v in @@ -93,8 +77,7 @@ module Check_closed (CA : Maker) (K : Hash.S) (V : Type.S) = struct { closed = ref false; t } let close t = - if !(t.closed) then () - else ( + if not !(t.closed) then ( t.closed := true; S.close t.t) end From ed2cbd6f2d541f4e569a12486a3818bfd40e2095 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Fri, 2 Jun 2023 11:28:01 +0200 Subject: [PATCH 19/99] Fix irmin-graphql using lwt_eio --- src/irmin-graphql/dune | 3 +- src/irmin-graphql/server.ml | 382 +++++++++--------- src/irmin-graphql/server.mli | 2 +- src/irmin-graphql/unix/irmin_graphql_unix.mli | 2 - test/irmin-graphql/common.ml | 14 +- test/irmin-graphql/common.mli | 7 +- test/irmin-graphql/dune | 5 +- test/irmin-graphql/test.ml | 90 +++-- 8 files changed, 262 insertions(+), 243 deletions(-) diff --git a/src/irmin-graphql/dune b/src/irmin-graphql/dune index e5221faa3c..24ee1a5c89 100644 --- a/src/irmin-graphql/dune +++ b/src/irmin-graphql/dune @@ -10,6 +10,7 @@ graphql-lwt graphql_parser irmin - lwt) + lwt + lwt_eio) (instrumentation (backend bisect_ppx))) diff --git a/src/irmin-graphql/server.ml b/src/irmin-graphql/server.ml index 2cd1c1a0ab..5b61253194 100644 --- a/src/irmin-graphql/server.ml +++ b/src/irmin-graphql/server.ml @@ -31,7 +31,7 @@ module type S = sig val execute_request : unit Schema.schema -> - Cohttp_lwt.Request.t -> + Cohttp.Request.t -> Cohttp_lwt.Body.t -> response_action Lwt.t @@ -195,17 +195,14 @@ struct let author = input.author in let parents = match input.parents with - | Some l -> - Lwt_list.filter_map_s (Store.Commit.of_key repo) l - >>= Lwt.return_some - | None -> Lwt.return_none + | Some l -> Some (List.filter_map (Store.Commit.of_key repo) l) + | None -> None in - let+ parents = parents in ( Config.info ?author "%s" message, input.retries, input.allow_empty, parents ) - | None -> Lwt.return (Config.info "", None, None, None) + | None -> (Config.info "", None, None, None) type response_action = [ `Expert of Cohttp.Response.t * (IO.ic -> IO.oc -> unit Lwt.t) @@ -325,47 +322,44 @@ struct [ field "path" ~typ:(non_null Types.Path.schema_typ) ~args:[] ~resolve:(fun _ (_, path) -> path); - io_field "get" + field "get" ~args:Arg.[ arg "path" ~typ:(non_null Input.path) ] ~typ:Types.Contents.schema_typ - ~resolve:(fun _ (tree, _) path -> - Store.Tree.find tree path >|= Result.ok); - io_field "get_contents" + ~resolve:(fun _ (tree, _) path -> Store.Tree.find tree path); + field "get_contents" ~args:Arg.[ arg "path" ~typ:(non_null Input.path) ] ~typ:t.contents ~resolve:(fun _ (tree, tree_path) path -> Store.Tree.find_all tree path - >|= Option.map (fun (c, m) -> - let path' = concat_path tree_path path in - (c, m, path')) - >|= Result.ok); - io_field "get_tree" + |> Option.map (fun (c, m) -> + let path' = concat_path tree_path path in + (c, m, path'))); + field "get_tree" ~args:Arg.[ arg "path" ~typ:(non_null Input.path) ] ~typ:t.tree ~resolve:(fun _ (tree, tree_path) path -> Store.Tree.find_tree tree path - >|= Option.map (fun tree -> - let tree_path' = concat_path tree_path path in - (tree, tree_path')) - >|= Result.ok); - io_field "list_contents_recursively" ~args:[] + |> Option.map (fun tree -> + let tree_path' = concat_path tree_path path in + (tree, tree_path'))); + field "list_contents_recursively" ~args:[] ~typ:(non_null (list (non_null t.contents))) ~resolve:(fun _ (tree, path) -> let rec tree_list ?(acc = []) tree path = match Store.Tree.destruct tree with | `Contents (c, m) -> - Store.Tree.Contents.force_exn c >|= fun c -> + let c = Store.Tree.Contents.force_exn c in (c, m, path) :: acc | `Node _ -> - let* l = Store.Tree.list tree Store.Path.empty in - Lwt_list.fold_left_s + let l = Store.Tree.list tree Store.Path.empty in + List.fold_left (fun acc (step, t) -> let path' = Store.Path.rcons path step in tree_list t path' ~acc) acc l - >|= List.rev + |> List.rev in - tree_list tree path >>= Lwt.return_ok); + tree_list tree path); field "hash" ~typ:(non_null Types.Hash.schema_typ) ~args:[] ~resolve:(fun _ (tree, _) -> Store.Tree.hash tree); field "key" ~typ:kinded_key ~args:[] @@ -378,24 +372,23 @@ struct let f = Lazy.force node_key_as_kinded_key in Some (f k) | None -> None); - io_field "list" + field "list" ~typ:(non_null (list (non_null node))) ~args:[] ~resolve:(fun _ (tree, tree_path) -> Store.Tree.list tree Store.Path.empty - >>= Lwt_list.map_s (fun (step, tree) -> - let absolute_path = - Store.Path.rcons tree_path step - in - match Store.Tree.destruct tree with - | `Contents (c, m) -> - let+ c = Store.Tree.Contents.force_exn c in - let f = Lazy.force contents_as_node in - f (c, m, absolute_path) - | _ -> - let f = Lazy.force tree_as_node in - Lwt.return (f (tree, absolute_path))) - >|= Result.ok); + |> List.map (fun (step, tree) -> + let absolute_path = + Store.Path.rcons tree_path step + in + match Store.Tree.destruct tree with + | `Contents (c, m) -> + let c = Store.Tree.Contents.force_exn c in + let f = Lazy.force contents_as_node in + f (c, m, absolute_path) + | _ -> + let f = Lazy.force tree_as_node in + f (tree, absolute_path))); ])) in let branch = @@ -404,13 +397,13 @@ struct [ field "name" ~typ:(non_null Types.Branch.schema_typ) ~args:[] ~resolve:(fun _ (_, b) -> b); - io_field "head" ~args:[] ~typ:t.commit - ~resolve:(fun _ (t, _) -> Store.Head.find t >|= Result.ok); - io_field "tree" ~args:[] ~typ:(non_null t.tree) + field "head" ~args:[] ~typ:t.commit ~resolve:(fun _ (t, _) -> + Store.Head.find t); + field "tree" ~args:[] ~typ:(non_null t.tree) ~resolve:(fun _ (t, _) -> - let+ tree = Store.tree t in - Ok (tree, Store.Path.empty)); - io_field "last_modified" + let tree = Store.tree t in + (tree, Store.Path.empty)); + field "last_modified" ~typ:(non_null (list (non_null t.commit))) ~args: Arg. @@ -420,21 +413,22 @@ struct arg "n" ~typ:int; ] ~resolve:(fun _ (t, _) path depth n -> - Store.last_modified ?depth ?n t path >|= Result.ok); + Store.last_modified ?depth ?n t path); io_field "lcas" ~typ:(non_null (list (non_null t.commit))) ~args:Arg.[ arg "commit" ~typ:(non_null Input.hash) ] ~resolve:(fun _ (t, _) commit -> - Store.Commit.of_hash (Store.repo t) commit >>= function + Lwt_eio.run_eio @@ fun () -> + match Store.Commit.of_hash (Store.repo t) commit with | Some commit -> ( - Store.lcas_with_commit t commit >>= function - | Ok lcas -> Lwt.return (Ok lcas) + match Store.lcas_with_commit t commit with + | Ok lcas -> Ok lcas | Error e -> let msg = Irmin.Type.to_string Store.lca_error_t e in - Lwt.return (Error msg)) - | None -> Lwt.return (Error "Commit not found")); + Error msg) + | None -> Error "Commit not found"); ])) in let contents = @@ -505,9 +499,7 @@ struct let _ = Lazy.force node_key_as_kinded_key let _ = Lazy.force contents_key_as_kinded_key let store_schema = Lazy.force store_schema - - let err_write e = - Lwt.return (Error (Irmin.Type.to_string Store.write_error_t e)) + let err_write e = Error (Irmin.Type.to_string Store.write_error_t e) let remote s = match Config.remote with @@ -522,12 +514,13 @@ struct arg "remote" ~typ:(non_null Input.remote); ] ~resolve:(fun _ _src branch remote -> - let* t = mk_branch s branch in - let* remote = remote in - Sync.fetch t remote >>= function - | Ok (`Head d) -> Store.Head.set t d >|= fun () -> Ok (Some d) - | Ok `Empty -> Lwt.return (Ok None) - | Error (`Msg e) -> Lwt.return (Error e)); + Lwt_eio.run_eio @@ fun () -> + let t = mk_branch s branch in + let remote = Lwt_eio.run_lwt @@ fun () -> remote in + match Sync.fetch t remote with + | Ok (`Head d) -> Store.Head.set t d |> fun () -> Ok (Some d) + | Ok `Empty -> Ok None + | Error (`Msg e) -> Error e); io_field "push" ~typ:store_schema.commit ~args: Arg. @@ -537,14 +530,15 @@ struct arg "depth" ~typ:int; ] ~resolve:(fun _ _src branch remote depth -> - let* t = mk_branch s branch in - let* remote = remote in - Sync.push t ?depth remote >>= function - | Ok (`Head commit) -> Lwt.return (Ok (Some commit)) - | Ok `Empty -> Lwt.return (Ok None) + Lwt_eio.run_eio @@ fun () -> + let t = mk_branch s branch in + let remote = Lwt_eio.run_lwt @@ fun () -> remote in + match Sync.push t ?depth remote with + | Ok (`Head commit) -> Ok (Some commit) + | Ok `Empty -> Ok None | Error e -> let s = Fmt.to_to_string Sync.pp_push_error e in - Lwt.return (Error s)); + Error s); io_field "pull" ~typ:store_schema.commit ~args: Arg. @@ -555,26 +549,26 @@ struct arg "depth" ~typ:int; ] ~resolve:(fun _ _src branch remote info depth -> - let* t = mk_branch s branch in + Lwt_eio.run_eio @@ fun () -> + let t = mk_branch s branch in let strategy = match info with | Some info -> - let+ info, _, _, _ = txn_args s (Some info) in + let info, _, _, _ = txn_args s (Some info) in `Merge info - | None -> Lwt.return `Set + | None -> `Set in - let* remote = remote in - strategy >>= Sync.pull ?depth t remote >>= function - | Ok (`Head h) -> Lwt.return (Ok (Some h)) - | Ok `Empty -> Lwt.return (Ok None) - | Error (`Msg msg) -> Lwt.return (Error msg) - | Error (`Conflict msg) -> - Lwt.return (Error ("conflict: " ^ msg))); + let remote = Lwt_eio.run_lwt @@ fun () -> remote in + match Sync.pull ?depth t remote strategy with + | Ok (`Head h) -> Ok (Some h) + | Ok `Empty -> Ok None + | Error (`Msg msg) -> Error msg + | Error (`Conflict msg) -> Error ("conflict: " ^ msg)); ] | None -> [] let to_tree tree l = - Lwt_list.fold_left_s + List.fold_left (fun tree -> function | { path; value = Some v; metadata } -> Store.Tree.add tree ?metadata path v @@ -595,10 +589,11 @@ struct arg "info" ~typ:Input.info; ] ~resolve:(fun _ _src branch k v i -> - let* t = mk_branch s branch in - let* info, retries, allow_empty, parents = txn_args s i in - Store.set t ?retries ?allow_empty ?parents k v ~info >>= function - | Ok () -> Store.Head.find t >|= Result.ok + Lwt_eio.run_eio @@ fun () -> + let t = mk_branch s branch in + let info, retries, allow_empty, parents = txn_args s i in + match Store.set t ?retries ?allow_empty ?parents k v ~info with + | Ok () -> Store.Head.find t |> Result.ok | Error e -> err_write e); io_field "set_tree" ~typ:store_schema.commit ~doc:"Set the tree at \"path\"" @@ -611,17 +606,18 @@ struct arg "info" ~typ:Input.info; ] ~resolve:(fun _ _src branch k items i -> - let* t = mk_branch s branch in - let* info, retries, allow_empty, parents = txn_args s i in - Lwt.catch - (fun () -> - let tree = Store.Tree.empty () in - let* tree = to_tree tree items in + Lwt_eio.run_eio @@ fun () -> + let t = mk_branch s branch in + let info, retries, allow_empty, parents = txn_args s i in + try + let tree = Store.Tree.empty () in + let tree = to_tree tree items in + match Store.set_tree t ?retries ?allow_empty ?parents ~info k tree - >>= function - | Ok _ -> Store.Head.find t >|= Result.ok - | Error e -> err_write e) - (function Failure e -> Lwt.return (Error e) | e -> raise e)); + with + | Ok _ -> Store.Head.find t |> Result.ok + | Error e -> err_write e + with Failure e -> Error e); io_field "update_tree" ~typ:store_schema.commit ~doc:"Add/remove items from the tree specified by \"path\"" ~args: @@ -633,10 +629,11 @@ struct arg "info" ~typ:Input.info; ] ~resolve:(fun _ _src branch k items i -> - let* t = mk_branch s branch in - let* info, retries, allow_empty, parents = txn_args s i in - Lwt.catch - (fun () -> + Lwt_eio.run_eio @@ fun () -> + let t = mk_branch s branch in + let info, retries, allow_empty, parents = txn_args s i in + try + match Store.with_tree t ?retries ?allow_empty ?parents k ~info (fun tree -> let tree = @@ -644,11 +641,11 @@ struct | Some t -> t | None -> Store.Tree.empty () in - to_tree tree items >>= Lwt.return_some) - >>= function - | Ok _ -> Store.Head.find t >|= Result.ok - | Error e -> err_write e) - (function Failure e -> Lwt.return (Error e) | e -> raise e)); + Some (to_tree tree items)) + with + | Ok _ -> Store.Head.find t |> Result.ok + | Error e -> err_write e + with Failure e -> Error e); io_field "set_all" ~typ:store_schema.commit ~doc:"Set contents and metadata" ~args: @@ -661,17 +658,19 @@ struct arg "info" ~typ:Input.info; ] ~resolve:(fun _ _src branch k v m i -> - let* t = mk_branch s branch in - let* info, retries, allow_empty, parents = txn_args s i in - let* tree = - Store.find_tree t k >>= function - | Some tree -> Lwt.return tree - | None -> Lwt.return (Store.Tree.empty ()) + Lwt_eio.run_eio @@ fun () -> + let t = mk_branch s branch in + let info, retries, allow_empty, parents = txn_args s i in + let tree = + match Store.find_tree t k with + | Some tree -> tree + | None -> Store.Tree.empty () in - let* tree = Store.Tree.add tree k ?metadata:m v in - Store.set_tree t ?retries ?allow_empty ?parents k tree ~info - >>= function - | Ok () -> Store.Head.find t >|= Result.ok + let tree = Store.Tree.add tree k ?metadata:m v in + match + Store.set_tree t ?retries ?allow_empty ?parents k tree ~info + with + | Ok () -> Store.Head.find t |> Result.ok | Error e -> err_write e); io_field "test_and_set" ~typ:store_schema.commit ~doc: @@ -687,12 +686,14 @@ struct arg "info" ~typ:Input.info; ] ~resolve:(fun _ _src branch k test set i -> - let* t = mk_branch s branch in - let* info, retries, allow_empty, parents = txn_args s i in - Store.test_and_set ?retries ?allow_empty ?parents ~info t k ~test - ~set - >>= function - | Ok _ -> Store.Head.find t >|= Result.ok + Lwt_eio.run_eio @@ fun () -> + let t = mk_branch s branch in + let info, retries, allow_empty, parents = txn_args s i in + match + Store.test_and_set ?retries ?allow_empty ?parents ~info t k ~test + ~set + with + | Ok _ -> Store.Head.find t |> Result.ok | Error e -> err_write e); io_field "test_set_and_get" ~typ:store_schema.commit ~doc: @@ -709,12 +710,14 @@ struct arg "info" ~typ:Input.info; ] ~resolve:(fun _ _src branch k test set i -> - let* t = mk_branch s branch in - let* info, retries, allow_empty, parents = txn_args s i in - Store.test_set_and_get ?retries ?allow_empty ?parents ~info t k - ~test ~set - >>= function - | Ok _ as v -> Lwt.return v + Lwt_eio.run_eio @@ fun () -> + let t = mk_branch s branch in + let info, retries, allow_empty, parents = txn_args s i in + match + Store.test_set_and_get ?retries ?allow_empty ?parents ~info t k + ~test ~set + with + | Ok _ as v -> v | Error e -> err_write e); io_field "test_and_set_branch" ~typ:(non_null bool) ~doc: @@ -728,9 +731,9 @@ struct arg "set" ~typ:Input.commit_key; ] ~resolve:(fun _ _src branch test set -> + Lwt_eio.run_eio @@ fun () -> let branches = Store.Backend.Repo.branch_t s in - Store.Backend.Branch.test_and_set branches branch ~test ~set - >|= Result.ok); + Ok (Store.Backend.Branch.test_and_set branches branch ~test ~set)); io_field "remove" ~typ:store_schema.commit ~doc:"Remove a path from the store" ~args: @@ -741,10 +744,11 @@ struct arg "info" ~typ:Input.info; ] ~resolve:(fun _ _src branch key i -> - let* t = mk_branch s branch in - let* info, retries, allow_empty, parents = txn_args s i in - Store.remove t ?retries ?allow_empty ?parents key ~info >>= function - | Ok () -> Store.Head.find t >|= Result.ok + Lwt_eio.run_eio @@ fun () -> + let t = mk_branch s branch in + let info, retries, allow_empty, parents = txn_args s i in + match Store.remove t ?retries ?allow_empty ?parents key ~info with + | Ok () -> Store.Head.find t |> Result.ok | Error e -> err_write e); io_field "merge" ~typ:Types.Hash.schema_typ ~doc:"Merge the current value at the given path with another value" @@ -758,11 +762,13 @@ struct arg "info" ~typ:Input.info; ] ~resolve:(fun _ _src branch key value old info -> - let* t = mk_branch s branch in - let* info, retries, allow_empty, parents = txn_args s info in - Store.merge t key ~info ?retries ?allow_empty ?parents ~old value - >>= function - | Ok _ -> Store.hash t key >|= Result.ok + Lwt_eio.run_eio @@ fun () -> + let t = mk_branch s branch in + let info, retries, allow_empty, parents = txn_args s info in + match + Store.merge t key ~info ?retries ?allow_empty ?parents ~old value + with + | Ok _ -> Store.hash t key |> Result.ok | Error e -> err_write e); io_field "merge_tree" ~typ:store_schema.commit ~doc:"Merge a branch with a tree" @@ -776,26 +782,28 @@ struct arg "info" ~typ:Input.info; ] ~resolve:(fun _ _src branch key value old info -> - let* t = mk_branch s branch in - let* info, retries, allow_empty, parents = txn_args s info in - let* old = + Lwt_eio.run_eio @@ fun () -> + let t = mk_branch s branch in + let info, retries, allow_empty, parents = txn_args s info in + let old = match old with | Some old -> let tree = Store.Tree.empty () in - to_tree tree old >>= Lwt.return_some - | None -> Lwt.return_none + Some (to_tree tree old) + | None -> None in - let* value = + let value = match value with | Some value -> let tree = Store.Tree.empty () in - to_tree tree value >>= Lwt.return_some - | None -> Lwt.return_none + Some (to_tree tree value) + | None -> None in - Store.merge_tree t key ~info ?retries ?allow_empty ?parents ~old - value - >>= function - | Ok _ -> Store.Head.find t >|= Result.ok + match + Store.merge_tree t key ~info ?retries ?allow_empty ?parents ~old + value + with + | Ok _ -> Store.Head.find t |> Result.ok | Error e -> err_write e); io_field "merge_with_branch" ~typ:store_schema.commit ~doc:"Merge a branch with another branch" @@ -809,10 +817,11 @@ struct arg "n" ~typ:int; ] ~resolve:(fun _ _src into from i max_depth n -> - let* t = mk_branch s into in - let* info, _, _, _ = txn_args s i in - let* _ = Store.merge_with_branch t from ~info ?max_depth ?n in - Store.Head.find t >|= Result.ok); + Lwt_eio.run_eio @@ fun () -> + let t = mk_branch s into in + let info, _, _, _ = txn_args s i in + let _ = Store.merge_with_branch t from ~info ?max_depth ?n in + Ok (Store.Head.find t)); io_field "merge_with_commit" ~doc:"Merge a branch with a specific commit" ~typ:store_schema.commit ~args: @@ -825,16 +834,16 @@ struct arg "n" ~typ:int; ] ~resolve:(fun _ _src into from i max_depth n -> - let* t = mk_branch s into in - let* info, _, _, _ = txn_args s i in - Store.Commit.of_hash (Store.repo t) from >>= function + Lwt_eio.run_eio @@ fun () -> + let t = mk_branch s into in + let info, _, _, _ = txn_args s i in + match Store.Commit.of_hash (Store.repo t) from with | Some from -> ( - Store.merge_with_commit t from ~info ?max_depth ?n >>= function - | Ok _ -> Store.Head.find t >|= Result.ok + match Store.merge_with_commit t from ~info ?max_depth ?n with + | Ok _ -> Store.Head.find t |> Result.ok | Error e -> - Lwt.return - (Error (Irmin.Type.to_string Irmin.Merge.conflict_t e))) - | None -> Lwt.return (Error "invalid hash")); + Error (Irmin.Type.to_string Irmin.Merge.conflict_t e)) + | None -> Error "invalid hash"); io_field "revert" ~doc:"Revert to a previous commit" ~typ:store_schema.commit ~args: @@ -844,11 +853,13 @@ struct arg "commit" ~typ:(non_null Input.hash); ] ~resolve:(fun _ _src branch commit -> - Store.Commit.of_hash s commit >>= function + Lwt_eio.run_eio @@ fun () -> + match Store.Commit.of_hash s commit with | Some commit -> - let* t = mk_branch s branch in - Store.Head.set t commit >|= fun () -> Ok (Some commit) - | None -> Lwt.return (Ok None)); + let t = mk_branch s branch in + Store.Head.set t commit; + Ok (Some commit) + | None -> Ok None); ] let diff = @@ -875,22 +886,19 @@ struct ~args: Arg.[ arg "branch" ~typ:Input.branch; arg "path" ~typ:Input.path ] ~resolve:(fun _ctx branch path -> - let* t = mk_branch s branch in + Lwt_eio.run_eio @@ fun () -> + let t = mk_branch s branch in let stream, push = Lwt_stream.create () in let destroy_stream watch () = push None; - Lwt.ignore_result (Store.unwatch watch) + Store.unwatch watch in match path with | None -> - let+ watch = - Store.watch t (fun diff -> - push (Some diff); - Lwt.return_unit) - in + let watch = Store.watch t (fun diff -> push (Some diff)) in Ok (stream, destroy_stream watch) | Some path -> - let+ watch = + let watch = Store.watch_key t path (function diff -> push (Some @@ -898,8 +906,7 @@ struct ~added:(fun (c, _) -> c) ~removed:(fun (c, _) -> c) ~updated:(fun (before, _) (after, _) -> - (before, after)))); - Lwt.return_unit) + (before, after))))) in Ok (stream, destroy_stream watch)); ] @@ -913,41 +920,50 @@ struct io_field "commit" ~doc:"Find commit by hash" ~typ:store_schema.commit ~args:Arg.[ arg "hash" ~typ:(non_null Input.hash) ] ~resolve:(fun _ _src hash -> - Store.Commit.of_hash s hash >|= Result.ok); + Lwt_eio.run_eio @@ fun () -> + Store.Commit.of_hash s hash |> Result.ok); io_field "contents" ~doc:"Find contents by hash" ~typ:Types.Contents.schema_typ ~args:Arg.[ arg "hash" ~typ:(non_null Input.hash) ] - ~resolve:(fun _ _src k -> Store.Contents.of_hash s k >|= Result.ok); + ~resolve:(fun _ _src k -> + Lwt_eio.run_eio @@ fun () -> + Store.Contents.of_hash s k |> Result.ok); io_field "contents_hash" ~doc:"Get the hash of some contents" ~typ:(non_null Types.Hash.schema_typ) ~args:Arg.[ arg "value" ~typ:(non_null Input.value) ] ~resolve:(fun _ _src c -> - Lwt.return (Store.Contents.hash c) >|= Result.ok); + Lwt_eio.run_eio @@ fun () -> Store.Contents.hash c |> Result.ok); io_field "commit_of_key" ~doc:"Find commit by key" ~typ:store_schema.commit ~args:Arg.[ arg "key" ~typ:(non_null Input.commit_key) ] - ~resolve:(fun _ _src k -> Store.Commit.of_key s k >|= Result.ok); + ~resolve:(fun _ _src k -> + Lwt_eio.run_eio @@ fun () -> Store.Commit.of_key s k |> Result.ok); io_field "contents_of_key" ~doc:"Find contents by key" ~typ:Types.Contents.schema_typ ~args:Arg.[ arg "key" ~typ:(non_null Input.contents_key) ] - ~resolve:(fun _ _src k -> Store.Contents.of_key s k >|= Result.ok); + ~resolve:(fun _ _src k -> + Lwt_eio.run_eio @@ fun () -> + Store.Contents.of_key s k |> Result.ok); io_field "branches" ~doc:"Get a list of all branches" ~typ:(non_null (list (non_null store_schema.branch))) ~args:[] ~resolve:(fun _ _ -> + Lwt_eio.run_eio @@ fun () -> Store.Branch.list s - >>= Lwt_list.map_p (fun branch -> - let+ store = Store.of_branch s branch in - (store, branch)) - >|= Result.ok); + |> List.map (fun branch -> + let store = Store.of_branch s branch in + (store, branch)) + |> Result.ok); io_field "main" ~doc:"Get main branch" ~typ:store_schema.branch ~args:[] ~resolve:(fun _ _ -> - let+ t = Store.main s in + Lwt_eio.run_eio @@ fun () -> + let t = Store.main s in Ok (Some (t, Store.Branch.main))); io_field "branch" ~doc:"Get branch by name" ~typ:store_schema.branch ~args:Arg.[ arg "name" ~typ:(non_null Input.branch) ] ~resolve:(fun _ _ branch -> - let+ t = Store.of_branch s branch in + Lwt_eio.run_eio @@ fun () -> + let t = Store.of_branch s branch in Ok (Some (t, branch))); ]) diff --git a/src/irmin-graphql/server.mli b/src/irmin-graphql/server.mli index a249bac40c..4bdc904ef2 100644 --- a/src/irmin-graphql/server.mli +++ b/src/irmin-graphql/server.mli @@ -32,7 +32,7 @@ module type S = sig val execute_request : unit Schema.schema -> Cohttp.Request.t -> - Cohttp.Body.t -> + Cohttp_lwt.Body.t -> response_action Lwt.t val v : repo -> server diff --git a/src/irmin-graphql/unix/irmin_graphql_unix.mli b/src/irmin-graphql/unix/irmin_graphql_unix.mli index 4e5afcdb6d..fc286e5cc1 100644 --- a/src/irmin-graphql/unix/irmin_graphql_unix.mli +++ b/src/irmin-graphql/unix/irmin_graphql_unix.mli @@ -32,7 +32,6 @@ module Server : sig Irmin_graphql.Server.S with type repo = S.repo and type server = Cohttp_lwt_unix.Server.t - and module IO = Cohttp_lwt_unix.IO module Make_ext (S : Irmin.Generic_key.S) @@ -51,5 +50,4 @@ module Server : sig Irmin_graphql.Server.S with type repo = S.repo and type server = Cohttp_lwt_unix.Server.t - and module IO = Cohttp_lwt_unix.IO end diff --git a/test/irmin-graphql/common.ml b/test/irmin-graphql/common.ml index b5e6109c5a..5d65207866 100644 --- a/test/irmin-graphql/common.ml +++ b/test/irmin-graphql/common.ml @@ -15,6 +15,8 @@ *) open! Import +open Lwt.Syntax +open Lwt.Infix module Store = Irmin_mem.KV.Make (Irmin.Contents.String) let ( / ) = Filename.concat @@ -62,8 +64,8 @@ type server = { event_loop : 'a. 'a Lwt.t; store : Store.t } let spawn_graphql_server () = let config = Irmin_mem.config () in - let* repo = Store.Repo.v config in - let+ main = Store.main repo in + let repo = Store.Repo.v config in + let main = Store.main repo in let event_loop = server_of_repo repo in { event_loop; store = main } @@ -167,7 +169,7 @@ let send_query : Cohttp_lwt_unix.Client.post ~headers ~body ~ctx (Uri.make ~scheme:"http" ~host ~path:"graphql" ())) in - let status = Cohttp_lwt.Response.status response in + let status = Cohttp.Response.status response in let+ body = Cohttp_lwt.Body.to_string body in match Cohttp.Code.(status |> code_of_status |> is_success) with | true -> Ok body @@ -187,11 +189,13 @@ let parse_result k f res = f (members k res) (** Issue a query to the localhost server, parse the response object and convert it using [f] *) let exec ?vars query f = - let* res = send_query ?vars (string_of_query query) in + let res = + Lwt_eio.run_lwt @@ fun () -> send_query ?vars (string_of_query query) + in match res with | Error (`Msg e) -> Alcotest.fail e | Ok res -> let res = Yojson.Safe.from_string res in let value = find_result res query in print_endline (Yojson.Safe.to_string value); - Lwt.return (f value) + f value diff --git a/test/irmin-graphql/common.mli b/test/irmin-graphql/common.mli index 59d6b3159a..07d75d3562 100644 --- a/test/irmin-graphql/common.mli +++ b/test/irmin-graphql/common.mli @@ -29,7 +29,7 @@ type server = { store : Store.t; (** The store used by the server *) } -val spawn_graphql_server : unit -> server Lwt.t +val spawn_graphql_server : unit -> server (** Initialise a GraphQL server. At most one server may be running concurrently. *) type param @@ -133,9 +133,6 @@ val parse_result : string list -> (Yojson.Safe.t -> 'a) -> Yojson.Safe.t -> 'a (** Get key from JSON object and apply conversion function *) val exec : - ?vars:(string * Yojson.Safe.t) list -> - query -> - (Yojson.Safe.t -> 'a) -> - 'a Lwt.t + ?vars:(string * Yojson.Safe.t) list -> query -> (Yojson.Safe.t -> 'a) -> 'a (** Send a [query] to the running GraphQL instance and parse the JSON results using the provided conversion function *) diff --git a/test/irmin-graphql/dune b/test/irmin-graphql/dune index 5f8d03744e..c79c8f56a7 100644 --- a/test/irmin-graphql/dune +++ b/test/irmin-graphql/dune @@ -3,14 +3,15 @@ (modules test common import) (libraries alcotest - alcotest-lwt yojson irmin irmin-graphql.unix irmin.mem cohttp-lwt-unix logs.fmt - logs)) + logs + lwt_eio + eio_main)) (rule (alias runtest) diff --git a/test/irmin-graphql/test.ml b/test/irmin-graphql/test.ml index 057518343b..92d77904d8 100644 --- a/test/irmin-graphql/test.ml +++ b/test/irmin-graphql/test.ml @@ -44,7 +44,7 @@ let set_tree store tree = Store.Tree.of_concrete tree |> Store.set_tree_exn ~info:Store.Info.none store [] -type test_case = Store.t -> unit Lwt.t +type test_case = Store.t -> unit let test_get_contents_list : test_case = fun store -> @@ -57,8 +57,8 @@ let test_get_contents_list : test_case = ~params:[ ("path", string "a/b/c") ] (list [ field "path"; field "__typename" ]) in - set_tree store data >>= fun () -> - let+ (result : (string * Json.t) list) = exec query Json.to_assoc in + set_tree store data; + let (result : (string * Json.t) list) = exec query Json.to_assoc in Alcotest.(check (list (pair string yojson))) "Returned entry data is valid" [ ("path", `String "/a/b/c"); ("__typename", `String "Contents") ] @@ -67,10 +67,8 @@ let test_get_contents_list : test_case = let test_list_contents_recursively : test_case = fun store -> - let* () = - Store.set_exn store [ "a"; "b"; "c" ] "data" ~info:Store.Info.none - in - let* () = + let () = Store.set_exn store [ "a"; "b"; "c" ] "data" ~info:Store.Info.none in + let () = Store.set_exn store [ "a"; "b"; "d" ] "data1" ~info:Store.Info.none in let q = @@ -79,7 +77,7 @@ let test_list_contents_recursively : test_case = @@ func "tree" @@ func "list_contents_recursively" (list [ field "path"; field "value" ]) in - let+ contents = exec q Json.to_list >|= List.map Json.to_assoc in + let contents = exec q Json.to_list |> List.map Json.to_assoc in Alcotest.(check (list (list (pair string yojson)))) "Contents list matches" [ @@ -101,8 +99,8 @@ let test_get_tree_list : test_case = @@ func "get_tree" ~params:[ ("path", string "a/b/c") ] @@ func "list" (list [ field "path"; field "__typename" ]) in - set_tree store data >>= fun () -> - let+ path_data = exec query Json.(fun x -> to_list x |> List.map to_assoc) in + set_tree store data; + let path_data = exec query Json.(fun x -> to_list x |> List.map to_assoc) in Alcotest.(check (list (list (pair string yojson)))) "Returned entry data is valid" [ @@ -125,8 +123,8 @@ let test_get_last_modified : test_case = ~params:[ ("path", string "a") ] (list [ field "value"; field "__typename" ]) in - set_tree store data >>= fun () -> - let+ result = exec query Json.(fun m -> to_list m |> List.map to_assoc) in + set_tree store data; + let result = exec query Json.(fun m -> to_list m |> List.map to_assoc) in Alcotest.(check (list (list (pair string yojson)))) "Returned entry data is valid " [ [ ("value", `String "data"); ("__typename", `String "Contents") ] ] @@ -138,14 +136,14 @@ let test_commit : test_case = let query0 = query @@ func "main" @@ func "head" (list [ field "hash"; field "key" ]) in - let* result = exec query0 Json.to_assoc in + let result = exec query0 Json.to_assoc in let hash = List.assoc "hash" result |> Json.to_string in let key = List.assoc "key" result |> Json.to_string in let query1 = query @@ func "commit_of_key" ~params:[ ("key", var "key") ] @@ field "hash" in let vars = [ ("key", `String key) ] in - let+ hash' = exec ~vars query1 Json.to_string in + let hash' = exec ~vars query1 Json.to_string in Alcotest.(check string) "Hashes equal" hash hash' let test_mutation : test_case = @@ -155,7 +153,7 @@ let test_mutation : test_case = @@ func "set" ~params:[ ("path", string "foo"); ("value", string "bar") ] @@ field "hash" in - let* _hash = exec m Json.to_string in + let _hash = exec m Json.to_string in let q = query @@ func "main" @@ -163,8 +161,8 @@ let test_mutation : test_case = @@ func "get_contents" ~params:[ ("path", string "foo") ] @@ field "value" in - let* value = Store.get store [ "foo" ] in - let+ result' = exec q Json.to_string in + let value = Store.get store [ "foo" ] in + let result' = exec q Json.to_string in Alcotest.(check string) "Contents equal" "bar" result'; Alcotest.(check string) "Contents equal stored value" "bar" value @@ -198,7 +196,7 @@ let test_mutation_test_set_and_get : test_case = @@ func "info" @@ field "message" in - let* exec_message = exec ~vars m Json.to_string in + let exec_message = exec ~vars m Json.to_string in let q = query @@ func "main" @@ -206,8 +204,8 @@ let test_mutation_test_set_and_get : test_case = @@ func "get_contents" ~params:[ ("path", string "foo") ] @@ field "value" in - let* value = Store.get store [ "foo" ] in - let+ result' = exec q Json.to_string in + let value = Store.get store [ "foo" ] in + let result' = exec q Json.to_string in Alcotest.(check string) "Contents equal" "baz" result'; Alcotest.(check string) "Contents equal stored value" "baz" value; Alcotest.(check string) "Same commit message" message exec_message @@ -220,7 +218,7 @@ let test_contents_hash : test_case = @@ func "contents_hash" ~params:[ ("value", string v) ] @@ field "hash" in - let+ hash = exec m Json.to_string in + let hash = exec m Json.to_string in let actual_hash = Store.Contents.hash v |> Irmin.Type.to_string Store.Hash.t in @@ -228,14 +226,14 @@ let test_contents_hash : test_case = let test_update_tree : test_case = fun store -> - let* commit = Store.Head.get store in + let commit = Store.Head.get store in let hash = Store.Commit.hash commit |> Irmin.Type.to_string Store.hash_t in let m = mutation @@ func "update_tree" ~params:[ ("path", string "/"); ("tree", raw "[]") ] @@ field "hash" in - let* hash' = exec m Json.to_string in + let hash' = exec m Json.to_string in Alcotest.(check string) "Hashes equal" hash hash'; let m = mutation @@ -247,10 +245,10 @@ let test_update_tree : test_case = ] @@ field "hash" in - let* hash' = exec m Json.to_string in + let hash' = exec m Json.to_string in if String.equal hash hash' then Alcotest.fail "Hashes should not be equal after update"; - let* contents = Store.get store [ "foo" ] in + let contents = Store.get store [ "foo" ] in Alcotest.(check string) "Contents at foo" contents "bar1"; let m = mutation @@ -258,19 +256,19 @@ let test_update_tree : test_case = ~params:[ ("path", string "/"); ("tree", raw {| [{path: "foo"}] |}) ] @@ field "hash" in - let* () = exec m ignore in - let+ contents = Store.find store [ "foo" ] in + let () = exec m ignore in + let contents = Store.find store [ "foo" ] in Alcotest.(check (option string)) "Contents empty after update" contents None let test_remove : test_case = fun store -> let info () = Store.Info.v 0L in let path_param = string "test/remove" in - let* () = Store.set_exn store [ "test"; "remove" ] "XXX" ~info in + let () = Store.set_exn store [ "test"; "remove" ] "XXX" ~info in let m = mutation @@ func "remove" ~params:[ ("path", path_param) ] @@ field "hash" in - let* () = exec m ignore in + let () = exec m ignore in let q = query @@ func "main" @@ -278,17 +276,17 @@ let test_remove : test_case = @@ func "get_contents" ~params:[ ("path", path_param) ] @@ field "value" in - let+ c = exec q Json.to_string_option in + let c = exec q Json.to_string_option in Alcotest.(check (option string)) "Contents have been removed" c None let test_branch_list : test_case = fun store -> let repo = Store.repo store in - let* head = Store.Head.get store in - let* () = Store.Branch.set repo "A" head in - let* () = Store.Branch.set repo "B" head in + let head = Store.Head.get store in + let () = Store.Branch.set repo "A" head in + let () = Store.Branch.set repo "B" head in let q = query @@ func "branches" @@ list [ field "name" ] in - let+ branches = + let branches = exec q (fun x -> Json.to_list x |> List.map Json.to_assoc |> List.map List.hd) in @@ -303,7 +301,7 @@ let test_branch_list : test_case = [ ("name", `String "A"); ("name", `String "B"); ("name", `String "main") ] let test_revert store = - let* head = Store.Head.get store in + let head = Store.Head.get store in let parents = Store.Commit.parents head in let parent = List.hd parents in let parent_s = Irmin.Type.to_string Store.hash_t parent in @@ -312,17 +310,17 @@ let test_revert store = @@ func "revert" ~params:[ ("commit", string parent_s) ] @@ field "hash" in - let* hash = exec q Json.to_string in + let hash = exec q Json.to_string in Alcotest.(check string) "hash is parent hash" hash parent_s; - let+ new_head = Store.Head.get store in + let new_head = Store.Head.get store in let new_hash = Store.Commit.hash new_head |> Irmin.Type.to_string Store.hash_t in Alcotest.(check string) "parent is new head" parent_s new_hash let suite store = - let test_case : string -> test_case -> unit Alcotest_lwt.test_case = - fun name f -> Alcotest_lwt.test_case name `Quick (fun _ () -> f store) + let test_case : string -> test_case -> unit Alcotest.test_case = + fun name f -> Alcotest.test_case name `Quick (fun () -> f store) in [ ( "GRAPHQL", @@ -346,8 +344,12 @@ let () = Random.self_init (); Logs.set_reporter (Logs_fmt.reporter ()); Logs.set_level (Some Debug); - let main = - let* { event_loop; store } = spawn_graphql_server () in - Lwt.pick [ event_loop; Alcotest_lwt.run "irmin-graphql" (suite store) ] - in - Lwt_main.run main + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> + Lwt_eio.run_lwt @@ fun () -> + let { event_loop; store } = spawn_graphql_server () in + Lwt.pick + [ + event_loop; + (Lwt_eio.run_eio @@ fun () -> Alcotest.run "irmin-graphql" (suite store)); + ] From c93a6e18af5d1f9f73ab669d0b541f1c6d39aeb3 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Fri, 2 Jun 2023 12:26:11 +0200 Subject: [PATCH 20/99] Fix irmin-git using lwt_eio --- src/irmin-git/atomic_write.ml | 107 ++++++++++++----------- src/irmin-git/atomic_write_intf.ml | 6 +- src/irmin-git/backend.ml | 20 +++-- src/irmin-git/backend.mli | 6 +- src/irmin-git/content_addressable.ml | 13 +-- src/irmin-git/dune | 14 ++- src/irmin-git/irmin_git.ml | 25 +++--- src/irmin-git/irmin_git_intf.ml | 6 +- src/irmin-git/remote.ml | 3 + src/irmin-mirage/git/irmin_mirage_git.ml | 47 ++++++---- test/irmin-git/dune | 4 +- test/irmin-git/test.ml | 7 +- test/irmin-git/test_git.ml | 98 +++++++++++---------- test/irmin-git/test_git.mli | 4 +- test/irmin-git/test_git_unix.ml | 22 +++-- test/irmin-git/test_unix.ml | 6 +- 16 files changed, 210 insertions(+), 178 deletions(-) diff --git a/src/irmin-git/atomic_write.ml b/src/irmin-git/atomic_write.ml index ce50c1b7c0..9fe90fcd01 100644 --- a/src/irmin-git/atomic_write.ml +++ b/src/irmin-git/atomic_write.ml @@ -15,6 +15,8 @@ *) open Import +open Lwt.Infix +open Lwt.Syntax include Atomic_write_intf module Check_closed (S : Irmin.Atomic_write.S) = struct @@ -81,8 +83,8 @@ module Make (K : Key) (G : Git.S) = struct module W = Irmin.Backend.Watch.Make (Key) (Val) let handle_git_err = function - | Ok x -> Lwt.return x - | Error e -> Fmt.kstr Lwt.fail_with "%a" G.pp_error e + | Ok x -> x + | Error e -> Fmt.kstr failwith "%a" G.pp_error e type t = { bare : bool; @@ -90,14 +92,14 @@ module Make (K : Key) (G : Git.S) = struct git_head : G.Hash.t Git.Reference.contents; t : G.t; w : W.t; - m : Lwt_mutex.t; + m : Eio.Mutex.t; } let watches = Hashtbl.create 10 type key = Key.t type value = Val.t - type watch = W.watch * (unit -> unit Lwt.t) + type watch = W.watch * (unit -> unit) let branch_of_git r = let str = String.trim @@ Git.Reference.to_string r in @@ -107,6 +109,7 @@ module Make (K : Key) (G : Git.S) = struct let pp_key = Irmin.Type.pp Key.t let ref_read_opt t head = + Lwt_eio.run_lwt @@ fun () -> (* Make a best-effort attempt to check that the reference actually exists before [read]-ing it, since the [Error `Reference_not_found] case causes a spurious warning to be logged inside [ocaml-git]. *) @@ -122,10 +125,12 @@ module Make (K : Key) (G : Git.S) = struct | Error e -> Fmt.kstr Lwt.fail_with "%a" G.pp_error e) let mem { t; _ } r = + Lwt_eio.run_lwt @@ fun () -> [%log.debug "mem %a" pp_key r]; G.Ref.mem t (git_of_branch r) let find { t; _ } r = + Lwt_eio.run_lwt @@ fun () -> [%log.debug "find %a" pp_key r]; let b = git_of_branch r in let* exists = G.Ref.mem t b in @@ -149,35 +154,36 @@ module Make (K : Key) (G : Git.S) = struct None in W.listen_dir t.w dir ~key ~value:(find t) - else Lwt.return (fun () -> Lwt.return_unit) + else fun () -> () let watch_key t key ?init f = [%log.debug "watch_key %a" pp_key key]; - let* stop = listen_dir t in - let+ w = W.watch_key t.w key ?init f in + let stop = listen_dir t in + let w = W.watch_key t.w key ?init f in (w, stop) let watch t ?init f = [%log.debug "watch"]; - let* stop = listen_dir t in - let+ w = W.watch t.w ?init f in + let stop = listen_dir t in + let w = W.watch t.w ?init f in (w, stop) let unwatch t (w, stop) = - let* () = stop () in + stop (); W.unwatch t.w w let v ?lock ~head ~bare t = - let m = match lock with None -> Lwt_mutex.create () | Some l -> l in + let m = match lock with None -> Eio.Mutex.create () | Some l -> l in let dot_git = G.dotgit t in let write_head head = let head = Git.Reference.Ref head in - let+ () = - let+ r = + let () = + let r = if G.has_global_checkout then - Lwt_mutex.with_lock m (fun () -> + Eio.Mutex.use_rw ~protect:true m (fun () -> + Lwt_eio.run_lwt @@ fun () -> G.Ref.write t Git.Reference.head head) - else Lwt.return (Ok ()) + else Ok () in match r with | Error e -> [%log.err "Cannot create HEAD: %a" G.pp_error e] @@ -185,13 +191,13 @@ module Make (K : Key) (G : Git.S) = struct in head in - let+ git_head = + let git_head = match head with | Some h -> write_head h | None -> ( - ref_read_opt t Git.Reference.head >>= function + match ref_read_opt t Git.Reference.head with | None -> write_head (git_of_branch K.main) - | Some head -> Lwt.return head) + | Some head -> head) in let w = try Hashtbl.find watches (G.dotgit t) @@ -203,6 +209,7 @@ module Make (K : Key) (G : Git.S) = struct { git_head; bare; t; w; dot_git; m } let list { t; _ } = + Lwt_eio.run_lwt @@ fun () -> [%log.debug "list"]; let+ refs = G.Ref.list t in List.fold_left @@ -220,25 +227,26 @@ module Make (K : Key) (G : Git.S) = struct (* FIXME G.write_index t.t gk *) let _ = gk in - Lwt.return_unit) - else Lwt.return_unit + ()) let pp_branch = Irmin.Type.pp K.t let set t r k = [%log.debug "set %a" pp_branch r]; let gr = git_of_branch r in - Lwt_mutex.with_lock t.m @@ fun () -> - let* e = G.Ref.write t.t gr (Git.Reference.Uid k) in - let* () = handle_git_err e in - let* () = W.notify t.w r (Some k) in + Eio.Mutex.use_rw ~protect:true t.m @@ fun () -> + let e = + Lwt_eio.run_lwt @@ fun () -> G.Ref.write t.t gr (Git.Reference.Uid k) + in + handle_git_err e; + W.notify t.w r (Some k); write_index t gr k let remove t r = [%log.debug "remove %a" pp_branch r]; - Lwt_mutex.with_lock t.m @@ fun () -> - let* e = G.Ref.remove t.t (git_of_branch r) in - let* () = handle_git_err e in + Eio.Mutex.use_rw ~protect:true t.m @@ fun () -> + let e = Lwt_eio.run_lwt @@ fun () -> G.Ref.remove t.t (git_of_branch r) in + let () = handle_git_err e in W.notify t.w r None let eq_head_contents_opt x y = @@ -255,23 +263,23 @@ module Make (K : Key) (G : Git.S) = struct let gr = git_of_branch r in let c = function None -> None | Some h -> Some (Git.Reference.Uid h) in let ok r = - let+ () = handle_git_err r in + handle_git_err r; true in - Lwt_mutex.with_lock t.m (fun () -> - let* x = ref_read_opt t.t gr in - let* b = - if not (eq_head_contents_opt x (c test)) then Lwt.return_false + Eio.Mutex.use_rw ~protect:true t.m (fun () -> + let x = ref_read_opt t.t gr in + let b = + if not (eq_head_contents_opt x (c test)) then false else match c set with | None -> - let* r = G.Ref.remove t.t gr in + let r = Lwt_eio.run_lwt @@ fun () -> G.Ref.remove t.t gr in ok r | Some h -> - let* r = G.Ref.write t.t gr h in + let r = Lwt_eio.run_lwt @@ fun () -> G.Ref.write t.t gr h in ok r in - let* () = + let () = if (* We do not protect [write_index] because it can take a long time and we don't want to hold the lock for too long. Would @@ -280,29 +288,22 @@ module Make (K : Key) (G : Git.S) = struct convenience for the user). *) b then W.notify t.w r set - else Lwt.return_unit in - let+ () = - if b then - match set with - | None -> Lwt.return_unit - | Some v -> write_index t gr v - else Lwt.return_unit + let () = + if b then match set with None -> () | Some v -> write_index t gr v in b) - let close _ = Lwt.return_unit + let close _ = () let clear t = [%log.debug "clear"]; - Lwt_mutex.with_lock t.m (fun () -> - let* refs = G.Ref.list t.t in - Lwt_list.iter_p - (fun (r, _) -> - let* e = G.Ref.remove t.t r in - let* () = handle_git_err e in - match branch_of_git r with - | Some k -> W.notify t.w k None - | None -> Lwt.return_unit) - refs) + Eio.Mutex.use_rw ~protect:true t.m @@ fun () -> + let refs = Lwt_eio.run_lwt @@ fun () -> G.Ref.list t.t in + List.iter + (fun (r, _) -> + let e = Lwt_eio.run_lwt @@ fun () -> G.Ref.remove t.t r in + handle_git_err e; + match branch_of_git r with Some k -> W.notify t.w k None | None -> ()) + refs end diff --git a/src/irmin-git/atomic_write_intf.ml b/src/irmin-git/atomic_write_intf.ml index 92f5b2731f..adcb493aea 100644 --- a/src/irmin-git/atomic_write_intf.ml +++ b/src/irmin-git/atomic_write_intf.ml @@ -28,11 +28,7 @@ module type Sigs = sig include Irmin.Atomic_write.S with type key = K.t and type value = G.Hash.t val v : - ?lock:Lwt_mutex.t -> - head:G.Reference.t option -> - bare:bool -> - G.t -> - t Lwt.t + ?lock:Eio.Mutex.t -> head:G.Reference.t option -> bare:bool -> G.t -> t end module Check_closed (S : Irmin.Atomic_write.S) : sig diff --git a/src/irmin-git/backend.ml b/src/irmin-git/backend.ml index 7acccf408a..49d3fbe154 100644 --- a/src/irmin-git/backend.ml +++ b/src/irmin-git/backend.ml @@ -63,15 +63,15 @@ struct module S = Atomic_write.Make (Schema.Branch) (G) include Atomic_write.Check_closed (S) - let v ?lock ~head ~bare t = S.v ?lock ~head ~bare t >|= v + let v ?lock ~head ~bare t = S.v ?lock ~head ~bare t |> v end module Slice = Irmin.Backend.Slice.Make (Contents) (Node) (Commit) module Repo = struct let handle_git_err = function - | Ok x -> Lwt.return x - | Error e -> Fmt.kstr Lwt.fail_with "%a" G.pp_error e + | Ok x -> x + | Error e -> Fmt.kstr failwith "%a" G.pp_error e type t = { config : Irmin.config; closed : bool ref; g : G.t; b : Branch.t } @@ -106,24 +106,28 @@ struct let { root; dot_git; head; bare; _ } = config conf in let dotgit = fopt Fpath.v dot_git in let root = Fpath.v root in - let* g = G.v ?dotgit root >>= handle_git_err in - let+ b = Branch.v ~head ~bare g in + let g = Lwt_eio.run_lwt @@ fun () -> G.v ?dotgit root in + let g = handle_git_err g in + let b = Branch.v ~head ~bare g in { g; b; closed = ref false; config = (conf :> Irmin.config) } let config t = t.config - let close t = Branch.close t.b >|= fun () -> t.closed := true + + let close t = + Branch.close t.b; + t.closed := true end module Remote = struct include Remote.Make (G) (S) (Schema.Branch) - let v repo = Lwt.return repo.Repo.g + let v repo = repo.Repo.g end let git_of_repo r = r.Repo.g let repo_of_git ?head ?(bare = true) ?lock g = - let+ b = Branch.v ?lock ~head ~bare g in + let b = Branch.v ?lock ~head ~bare g in { Repo.config = Irmin.Backend.Conf.empty Conf.spec; closed = ref false; diff --git a/src/irmin-git/backend.mli b/src/irmin-git/backend.mli index fe261ae8a6..fbed34b7a1 100644 --- a/src/irmin-git/backend.mli +++ b/src/irmin-git/backend.mli @@ -43,9 +43,5 @@ module Make val git_of_repo : Repo.t -> G.t val repo_of_git : - ?head:Git.Reference.t -> - ?bare:bool -> - ?lock:Lwt_mutex.t -> - G.t -> - Repo.t Lwt.t + ?head:Git.Reference.t -> ?bare:bool -> ?lock:Eio.Mutex.t -> G.t -> Repo.t end diff --git a/src/irmin-git/content_addressable.ml b/src/irmin-git/content_addressable.ml index c0fd2c5128..0813f9b826 100644 --- a/src/irmin-git/content_addressable.ml +++ b/src/irmin-git/content_addressable.ml @@ -15,6 +15,8 @@ *) open Import +open Lwt.Infix +open Lwt.Syntax include Content_addressable_intf module Make (G : Git.S) (V : Value.S with type value := G.Value.t) = struct @@ -29,6 +31,7 @@ module Make (G : Git.S) (V : Value.S with type value := G.Value.t) = struct type value = V.t let mem t key = + Lwt_eio.run_lwt @@ fun () -> [%log.debug "mem %a" pp_key key]; G.mem t key >>= function | false -> Lwt.return_false @@ -39,6 +42,7 @@ module Make (G : Git.S) (V : Value.S with type value := G.Value.t) = struct | Ok v -> Lwt.return (V.type_eq (G.Value.kind v))) let find t key = + Lwt_eio.run_lwt @@ fun () -> [%log.debug "find %a" pp_key key]; G.read t key >>= function | Error (`Reference_not_found _ | `Not_found _) -> Lwt.return_none @@ -46,13 +50,14 @@ module Make (G : Git.S) (V : Value.S with type value := G.Value.t) = struct | Ok v -> Lwt.return (V.of_git v) let add t v = + Lwt_eio.run_lwt @@ fun () -> let v = V.to_git v in let* k, _ = G.write t v >>= handle_git_err in [%log.debug "add %a" pp_key k]; Lwt.return k let unsafe_add t k v = - let+ k' = add t v in + let k' = add t v in if equal_key k k' then () else Fmt.failwith @@ -60,7 +65,7 @@ module Make (G : Git.S) (V : Value.S with type value := G.Value.t) = struct pp_key k pp_key k' let batch t f = f t - let close _ = Lwt.return () + let close _ = () end module Check_closed (S : Irmin.Content_addressable.S) = struct @@ -90,7 +95,5 @@ module Check_closed (S : Irmin.Content_addressable.S) = struct check_not_closed t; S.batch (snd t) (fun x -> f (fst t, x)) - let close (c, _) = - c := true; - Lwt.return () + let close (c, _) = c := true end diff --git a/src/irmin-git/dune b/src/irmin-git/dune index 4e03acfc5e..6f793dc01c 100644 --- a/src/irmin-git/dune +++ b/src/irmin-git/dune @@ -1,7 +1,19 @@ (library (name irmin_git) (public_name irmin-git) - (libraries astring cstruct fmt fpath git irmin logs lwt uri irmin.mem mimic) + (libraries + astring + cstruct + fmt + fpath + git + irmin + logs + lwt + lwt_eio + uri + irmin.mem + mimic) (preprocess (pps ppx_irmin.internal)) (instrumentation diff --git a/src/irmin-git/irmin_git.ml b/src/irmin-git/irmin_git.ml index d62b30b994..6fc6b03724 100644 --- a/src/irmin-git/irmin_git.ml +++ b/src/irmin-git/irmin_git.ml @@ -46,6 +46,7 @@ struct let git_commit (repo : Repo.t) (h : commit) : G.Value.Commit.t option Lwt.t = + let open Lwt.Infix in let h = Commit.hash h in G.read (git_of_repo repo) h >|= function | Ok (Git.Value.Commit c) -> Some c @@ -68,6 +69,7 @@ module Mem = struct let v' ?dotgit root = v ?dotgit root let v ?dotgit root = + let open Lwt.Infix in let conf = (dotgit, root) in match find_conf conf with | Some x -> Lwt.return x @@ -126,7 +128,7 @@ module Content_addressable (G : Git.S) = struct module X = M.Backend.Contents let state t = - let+ r = M.repo_of_git (snd t) in + let r = M.repo_of_git (snd t) in M.Backend.Repo.contents_t r type 'a t = bool ref * G.t @@ -134,11 +136,11 @@ module Content_addressable (G : Git.S) = struct type value = X.value let with_state0 f t = - let* t = state t in + let t = state t in f t let with_state1 f t x = - let* t = state t in + let t = state t in f t x let add = with_state1 X.add @@ -146,7 +148,7 @@ module Content_addressable (G : Git.S) = struct let equal_key = Irmin.Type.(unstage (equal X.Key.t)) let unsafe_add t k v = - let+ k' = with_state1 X.add t v in + let k' = with_state1 X.add t v in if equal_key k k' then () else Fmt.failwith @@ -321,18 +323,19 @@ struct f contents_t node_t commit_t let v config = - let* contents = Contents.CA.v config in - let* nodes = Node.CA.v config in - let* commits = Commit.CA.v config in + let contents = Contents.CA.v config in + let nodes = Node.CA.v config in + let commits = Commit.CA.v config in let nodes = (contents, nodes) in let commits = (nodes, commits) in - let+ branch = Branch.v config in + let branch = Branch.v config in { contents; nodes; commits; branch; config } let close t = - Contents.CA.close t.contents >>= fun () -> - Node.CA.close (snd t.nodes) >>= fun () -> - Commit.CA.close (snd t.commits) >>= fun () -> Branch.close t.branch + Contents.CA.close t.contents; + Node.CA.close (snd t.nodes); + Commit.CA.close (snd t.commits); + Branch.close t.branch end end diff --git a/src/irmin-git/irmin_git_intf.ml b/src/irmin-git/irmin_git_intf.ml index f6e57f4841..87756648da 100644 --- a/src/irmin-git/irmin_git_intf.ml +++ b/src/irmin-git/irmin_git_intf.ml @@ -42,11 +42,7 @@ module type S = sig (** [of_repo r] is the Git store associated to [r]. *) val repo_of_git : - ?head:Git.Reference.t -> - ?bare:bool -> - ?lock:Lwt_mutex.t -> - Git.t -> - Repo.t Lwt.t + ?head:Git.Reference.t -> ?bare:bool -> ?lock:Eio.Mutex.t -> Git.t -> Repo.t (** [to_repo t] is the Irmin repository associated to [t]. *) end diff --git a/src/irmin-git/remote.ml b/src/irmin-git/remote.ml index d357af18e1..067ce0ecab 100644 --- a/src/irmin-git/remote.ml +++ b/src/irmin-git/remote.ml @@ -15,6 +15,7 @@ *) open Import +open Lwt.Infix let ( >>? ) = Lwt_result.bind @@ -42,6 +43,7 @@ struct let reword_error f = function Ok _ as v -> v | Error err -> Error (f err) let fetch t ?depth (ctx, e) br = + Lwt_eio.run_lwt @@ fun () -> [%log.debug "fetch %a" Smart_git.Endpoint.pp e]; let push_stdout msg = Gitlog.info (fun f -> f "%s" msg) and push_stderr msg = Gitlog.warn (fun f -> f "%s" msg) @@ -78,6 +80,7 @@ struct | _ -> assert false let push t ?depth:_ (ctx, e) br = + Lwt_eio.run_lwt @@ fun () -> [%log.debug "push %a" Smart_git.Endpoint.pp e]; let reference = git_of_branch br in let capabilities = diff --git a/src/irmin-mirage/git/irmin_mirage_git.ml b/src/irmin-mirage/git/irmin_mirage_git.ml index 324137be28..e02187b87c 100644 --- a/src/irmin-mirage/git/irmin_mirage_git.ml +++ b/src/irmin-mirage/git/irmin_mirage_git.ml @@ -140,18 +140,20 @@ module KV_RO (G : Git.S) = struct | Some v -> Ok v let get_partial t key ~offset ~length = - let open Lwt_result.Infix in - get t key >|= fun data -> - let len = String.length data in - let off = Optint.Int63.to_int offset in - if off >= len || off < 0 || length < 0 then "" - else - let l = min length (len - off) in - String.sub data off l + match get t key with + | Error e -> Error e + | Ok data -> + Ok + (let len = String.length data in + let off = Optint.Int63.to_int offset in + if off >= len || off < 0 || length < 0 then "" + else + let l = min length (len - off) in + String.sub data off l) let size t key = - let open Lwt_result.Infix in - get t key >|= fun data -> Optint.Int63.of_int (String.length data) + get t key + |> Result.map (fun data -> Optint.Int63.of_int (String.length data)) end type t = { root : S.path; t : S.t } @@ -191,16 +193,21 @@ module KV_RO (G : Git.S) = struct let get t k = tree t >>= fun t -> Tree.get t k let get_partial t k ~offset ~length = - tree t >>= fun t -> Tree.get_partial t k ~offset ~length + Lwt_eio.run_eio @@ fun () -> Tree.get_partial (tree t) k ~offset ~length let list t k = tree t >>= fun t -> Tree.list t k let digest t k = tree t >>= fun t -> Tree.digest t k let size t k = tree t >>= fun t -> Tree.size t k let get t k = - match Key.segments k with - | [ "HEAD" ] -> head_message t >|= fun v -> Ok v - | _ -> get t k + match Key.segments k with [ "HEAD" ] -> Ok (head_message t) | _ -> get t k + + let exists t k = Lwt_eio.run_eio @@ fun () -> exists t k + let get t k = Lwt_eio.run_eio @@ fun () -> get t k + let list t k = Lwt_eio.run_eio @@ fun () -> list t k + let digest t k = Lwt_eio.run_eio @@ fun () -> digest t k + let size t k = Lwt_eio.run_eio @@ fun () -> size t k + let last_modified t k = Lwt_eio.run_eio @@ fun () -> last_modified t k end module KV_RW (G : Irmin_git.G) (C : Mirage_clock.PCLOCK) = struct @@ -281,12 +288,17 @@ module KV_RW (G : Irmin_git.G) (C : Mirage_clock.PCLOCK) = struct let info t op = Info.f ~author:(t.author ()) "%s" (t.msg op) let path = RO.path + let write_error = function + | Ok _ -> Ok () + | Error e -> Error (e :> write_error) + let ( >?= ) r f = - r >>= function - | Error e -> Lwt.return_error (e :> write_error) - | Ok r -> f r + Lwt.bind r (function + | Error e -> Lwt.return_error (e :> write_error) + | Ok r -> f r) let set t k v = + Lwt_eio.run_eio @@ fun () -> let info = info t (`Set k) in match t.store with | Store s -> @@ -310,6 +322,7 @@ module KV_RW (G : Irmin_git.G) (C : Mirage_clock.PCLOCK) = struct set t k (Bytes.unsafe_to_string buf) let remove t k = + Lwt_eio.run_eio @@ fun () -> let info = info t (`Remove k) in match t.store with | Store s -> diff --git a/test/irmin-git/dune b/test/irmin-git/dune index 7bd68385fb..1f8daf7585 100644 --- a/test/irmin-git/dune +++ b/test/irmin-git/dune @@ -12,7 +12,9 @@ git git-unix lwt - lwt.unix) + lwt.unix + lwt_eio + eio_main) (preprocess (pps ppx_irmin ppx_irmin.internal))) diff --git a/test/irmin-git/test.ml b/test/irmin-git/test.ml index 154b15db4c..741d3b54de 100644 --- a/test/irmin-git/test.ml +++ b/test/irmin-git/test.ml @@ -17,6 +17,7 @@ let misc = [ ("misc", Test_git.(misc mem)) ] let () = - Lwt_main.run - @@ Irmin_test.Store.run "irmin-git" ~slow:true ~misc ~sleep:Lwt_unix.sleep - [ (`Quick, Test_git.suite); (`Quick, Test_git.suite_generic) ] + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> + Irmin_test.Store.run "irmin-git" ~slow:true ~misc ~sleep:Eio_unix.sleep + [ (`Quick, Test_git.suite); (`Quick, Test_git.suite_generic) ] diff --git a/test/irmin-git/test_git.ml b/test/irmin-git/test_git.ml index 1fae8fa6cc..167428a7a4 100644 --- a/test/irmin-git/test_git.ml +++ b/test/irmin-git/test_git.ml @@ -25,7 +25,7 @@ let config = module type S = sig include Irmin_test.S - val init : config:Irmin.config -> unit Lwt.t + val init : config:Irmin.config -> unit end module type G = sig @@ -56,6 +56,8 @@ module Mem (C : Irmin.Contents.S) = struct let test_db = Irmin.Backend.Conf.find_root config |> Option.value ~default:test_db in + Lwt_eio.run_lwt @@ fun () -> + let open Lwt.Infix in Git.v (Fpath.v test_db) >>= function | Ok t -> S.Git.reset t >|= fun _ -> () | _ -> Lwt.return_unit @@ -67,12 +69,12 @@ module Generic (C : Irmin.Contents.S) = struct include M.Make (C) let init ~config = - let* repo = Repo.v config in - Repo.branches repo >>= Lwt_list.iter_p (Branch.remove repo) + let repo = Repo.v config in + Repo.branches repo |> List.iter (Branch.remove repo) let clean ~config = - let* repo = Repo.v config in - Repo.branches repo >>= Lwt_list.iter_p (Branch.remove repo) >>= fun () -> + let repo = Repo.v config in + Repo.branches repo |> List.iter (Branch.remove repo); Repo.close repo end @@ -94,38 +96,38 @@ let get = function Some x -> x | None -> Alcotest.fail "get" let test_sort_order (module S : S) = let config = Irmin_git.config test_db in - S.init ~config >>= fun () -> - let* repo = S.Repo.v config in + S.init ~config; + let repo = S.Repo.v config in let commit_t = S.Backend.Repo.commit_t repo in let node_t = S.Backend.Repo.node_t repo in let head_tree_id branch = - let* head = S.Head.get branch in - let+ commit = S.Backend.Commit.find commit_t (S.Commit.hash head) in + let head = S.Head.get branch in + let commit = S.Backend.Commit.find commit_t (S.Commit.hash head) in S.Backend.Commit.Val.node (get commit) in let ls branch = - let* tree_id = head_tree_id branch in - let+ tree = S.Backend.Node.find node_t tree_id in + let tree_id = head_tree_id branch in + let tree = S.Backend.Node.find node_t tree_id in S.Backend.Node.Val.list (get tree) |> List.map fst in let info = S.Info.none in - let* main = S.main repo in - S.remove_exn main ~info [] >>= fun () -> - S.set_exn main ~info [ "foo.c" ] "foo.c" >>= fun () -> - S.set_exn main ~info [ "foo1" ] "foo1" >>= fun () -> - S.set_exn main ~info [ "foo"; "foo.o" ] "foo.o" >>= fun () -> - let* items = ls main in + let main = S.main repo in + S.remove_exn main ~info []; + S.set_exn main ~info [ "foo.c" ] "foo.c"; + S.set_exn main ~info [ "foo1" ] "foo1"; + S.set_exn main ~info [ "foo"; "foo.o" ] "foo.o"; + let items = ls main in Alcotest.(check (list string)) "Sort order" [ "foo.c"; "foo"; "foo1" ] items; - let* tree_id = head_tree_id main in + let tree_id = head_tree_id main in Alcotest.(check string) "Sort hash" "00c5f5e40e37fde61911f71373813c0b6cad1477" (Irmin.Type.to_string S.Backend.Node.Key.t tree_id); (* Convert dir to file; changes order in listing *) - S.set_exn main ~info [ "foo" ] "foo" >>= fun () -> - let* items = ls main in + S.set_exn main ~info [ "foo" ] "foo"; + let items = ls main in Alcotest.(check (list string)) "Sort order" [ "foo"; "foo.c"; "foo1" ] items; - Lwt.return_unit + () module Ref (S : Irmin_git.G) = struct module M = Irmin_git.Ref (S) (Git_unix.Sync (S)) @@ -143,15 +145,15 @@ let reference = Alcotest.testable pp_reference ( = ) let test_list_refs (module S : G) = let module R = Ref (S.Git) in let config = Irmin_git.config test_db in - S.init ~config >>= fun () -> - let* repo = R.Repo.v config in - let* main = R.main repo in - R.set_exn main ~info:R.Info.none [ "test" ] "toto" >>= fun () -> - let* head = R.Head.get main in - R.Branch.set repo (`Remote "datakit/main") head >>= fun () -> - R.Branch.set repo (`Other "foo/bar/toto") head >>= fun () -> - R.Branch.set repo (`Branch "foo") head >>= fun () -> - let* bs = R.Repo.branches repo in + S.init ~config; + let repo = R.Repo.v config in + let main = R.main repo in + R.set_exn main ~info:R.Info.none [ "test" ] "toto"; + let head = R.Head.get main in + R.Branch.set repo (`Remote "datakit/main") head; + R.Branch.set repo (`Other "foo/bar/toto") head; + R.Branch.set repo (`Branch "foo") head; + let bs = R.Repo.branches repo in Alcotest.(check (slist reference compare)) "raw branches" [ @@ -161,8 +163,8 @@ let test_list_refs (module S : G) = `Remote "datakit/main"; ] bs; - let* repo = S.Repo.v (Irmin_git.config test_db) in - let* bs = S.Repo.branches repo in + let repo = S.Repo.v (Irmin_git.config test_db) in + let bs = S.Repo.branches repo in Alcotest.(check (slist string String.compare)) "filtered branches" [ "main"; "foo" ] bs; @@ -174,7 +176,7 @@ let test_list_refs (module S : G) = Alcotest.(check (slist string String.compare)) "filtered branches" ["main";"foo"] bs else *) - Lwt.return_unit + () let bin_string = Alcotest.testable (Fmt.fmt "%S") ( = ) @@ -197,31 +199,33 @@ let test_blobs (module S : S) = Alcotest.(check bin_string) "blob ''" "blob 11\000{\"X\":[1,2]}" str; let t = X.Tree.singleton [ "foo" ] (X (1, 2)) in let k1 = X.Tree.hash t in - let* repo = X.Repo.v (Irmin_git.config test_db) in - let* k2 = - X.Backend.Repo.batch repo (fun x y _ -> X.save_tree ~clear:false repo x y t) - >|= function + let repo = X.Repo.v (Irmin_git.config test_db) in + let k2 = + match + X.Backend.Repo.batch repo (fun x y _ -> + X.save_tree ~clear:false repo x y t) + with | `Node k -> k | `Contents k -> k in let hash = Irmin_test.testable X.Hash.t in Alcotest.(check hash) "blob" k1 k2; - Lwt.return_unit + () let test_import_export (module S : S) = let module Generic = Generic (Irmin.Contents.String) in let module Sync = Irmin.Sync.Make (Generic) in let config = Irmin_git.config test_db in - S.init ~config >>= fun () -> - let* _ = Generic.init ~config in - let* repo = S.Repo.v config in - let* t = S.main repo in - S.set_exn t ~info:S.Info.none [ "test" ] "toto" >>= fun () -> + S.init ~config; + let _ = Generic.init ~config in + let repo = S.Repo.v config in + let t = S.main repo in + S.set_exn t ~info:S.Info.none [ "test" ] "toto"; let remote = Irmin.remote_store (module S) t in - let* repo = Generic.Repo.v (Irmin_mem.config ()) in - let* t = Generic.main repo in - let* _ = Sync.pull_exn t remote `Set in - let+ toto = Generic.get t [ "test" ] in + let repo = Generic.Repo.v (Irmin_mem.config ()) in + let t = Generic.main repo in + let _ = Sync.pull_exn t remote `Set in + let toto = Generic.get t [ "test" ] in Alcotest.(check string) "import" toto "toto" let misc (module S : G) = diff --git a/test/irmin-git/test_git.mli b/test/irmin-git/test_git.mli index 6191323f9a..532f377152 100644 --- a/test/irmin-git/test_git.mli +++ b/test/irmin-git/test_git.mli @@ -21,7 +21,7 @@ val test_db : string module type S = sig include Irmin_test.S - val init : config:Irmin.config -> unit Lwt.t + val init : config:Irmin.config -> unit end module type G = sig @@ -29,5 +29,5 @@ module type G = sig module Git : Irmin_git.G end -val misc : (module G) -> unit Alcotest_lwt.test_case list +val misc : (module G) -> unit Alcotest.test_case list val mem : (module G) diff --git a/test/irmin-git/test_git_unix.ml b/test/irmin-git/test_git_unix.ml index afeecf9ba8..4df19fd763 100644 --- a/test/irmin-git/test_git_unix.ml +++ b/test/irmin-git/test_git_unix.ml @@ -11,12 +11,13 @@ let init ~config = Irmin.Backend.Conf.find_root config |> Option.value ~default:test_db in assert (test_db <> ".git"); - let+ () = + let () = if Sys.file_exists test_db then + Lwt_eio.run_lwt @@ fun () -> + let open Lwt.Infix in Git_unix.Store.v (Fpath.v test_db) >>= function | Ok t -> Git_unix.Store.reset t >|= fun _ -> () | Error _ -> Lwt.return_unit - else Lwt.return_unit in Irmin.Backend.Watch.set_listen_dir_hook Irmin_watcher.hook @@ -28,10 +29,7 @@ module S = struct end let store = (module S : Test_git.G) - -let clean ~config:_ = - Irmin.Backend.Watch.(set_listen_dir_hook none); - Lwt.return_unit +let clean ~config:_ = Irmin.Backend.Watch.(set_listen_dir_hook none) let config = let head = Git.Reference.v "refs/heads/test" in @@ -43,13 +41,13 @@ let suite = let test_non_bare () = let config = Irmin_git.config ~bare:false test_db in - init ~config >>= fun () -> + init ~config; let info = Irmin_git_unix.info in - let* repo = S.Repo.v config in - let* t = S.main repo in - S.set_exn t ~info:(info "fst one") [ "fst" ] "ok" >>= fun () -> - S.set_exn t ~info:(info "snd one") [ "fst"; "snd" ] "maybe?" >>= fun () -> + let repo = S.Repo.v config in + let t = S.main repo in + S.set_exn t ~info:(info "fst one") [ "fst" ] "ok"; + S.set_exn t ~info:(info "snd one") [ "fst"; "snd" ] "maybe?"; S.set_exn t ~info:(info "fst one") [ "fst" ] "hoho" let misc : unit Alcotest.test_case list = - [ ("non-bare", `Quick, fun () -> Lwt_main.run (test_non_bare ())) ] + [ ("non-bare", `Quick, fun () -> test_non_bare ()) ] diff --git a/test/irmin-git/test_unix.ml b/test/irmin-git/test_unix.ml index 9e3157ec8f..3610f80f3f 100644 --- a/test/irmin-git/test_unix.ml +++ b/test/irmin-git/test_unix.ml @@ -18,6 +18,6 @@ let misc = [ ("misc", Test_git.misc Test_git_unix.store) ] let suites = [ (`Quick, Test_git_unix.suite) ] let () = - Lwt_main.run - @@ Irmin_test.Store.run "irmin-git.unix" ~misc ~slow:false - ~sleep:Lwt_unix.sleep suites + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> + Irmin_test.Store.run "irmin-git.unix" ~misc ~sleep:Eio_unix.sleep suites From 7f4d26caf25a48a5201871419aadb9b1d5876dc4 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Fri, 2 Jun 2023 17:01:50 +0200 Subject: [PATCH 21/99] Fix irmin-cli using lwt_eio --- src/irmin-cli/cli.ml | 518 +++++++++--------- src/irmin-cli/dune | 4 +- src/irmin-cli/resolver.ml | 25 +- src/irmin-cli/resolver.mli | 7 +- src/irmin-git/unix/dune | 2 +- src/irmin-git/unix/xgit.ml | 15 +- src/irmin-git/unix/xgit_intf.ml | 2 +- src/irmin-graphql/server.ml | 9 +- src/irmin-graphql/server.mli | 3 +- src/irmin-graphql/unix/irmin_graphql_unix.ml | 2 +- src/irmin-graphql/unix/irmin_graphql_unix.mli | 2 +- test/irmin-cli/test.ml | 5 +- 12 files changed, 298 insertions(+), 296 deletions(-) diff --git a/src/irmin-cli/cli.ml b/src/irmin-cli/cli.ml index ceadcf7089..48b1d2b782 100644 --- a/src/irmin-cli/cli.ml +++ b/src/irmin-cli/cli.ml @@ -108,7 +108,14 @@ let print_exc exc = | e -> Fmt.epr "ERROR: %a\n%!" Fmt.exn e); exit 1 -let run t = Lwt_main.run (Lwt.catch (fun () -> t) print_exc) +open Lwt.Syntax + +let run t = + Eio_main.run @@ fun env -> + Irmin_fs.run env#fs @@ fun () -> + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> + try t () with err -> print_exc err + let mk (fn : 'a) : 'a Term.t = Term.(const (fun () -> fn) $ setup_log) (* INIT *) @@ -118,7 +125,7 @@ let init = doc = "Initialize a store."; man = []; term = - (let init (S (_, _store, _)) = run Lwt.return_unit in + (let init (S (_, _store, _)) = () in Term.(mk init $ store ())); } @@ -143,15 +150,13 @@ let get = term = (let get (S (impl, store, _)) path = let (module S) = Store.Impl.generic_keyed impl in - run - (let* t = store in - S.find t (key S.Path.t path) >>= function - | None -> - print ""; - exit 1 - | Some v -> - print "%a" (Irmin.Type.pp S.Contents.t) v; - Lwt.return_unit) + run @@ fun () -> + let t = store () in + match S.find t (key S.Path.t path) with + | None -> + print ""; + exit 1 + | Some v -> print "%a" (Irmin.Type.pp S.Contents.t) v in Term.(mk get $ store () $ path)); } @@ -170,17 +175,16 @@ let list = | Empty -> S.Path.empty | Path str -> key S.Path.t str in - run - (let* t = store in - let* paths = S.list t path in - let pp_step = Irmin.Type.pp S.Path.step_t in - let pp ppf (s, k) = - match S.Tree.destruct k with - | `Contents _ -> Fmt.pf ppf "FILE %a" pp_step s - | `Node _ -> Fmt.pf ppf "DIR %a" pp_step s - in - List.iter (print "%a" pp) paths; - Lwt.return_unit) + run @@ fun () -> + let t = store () in + let paths = S.list t path in + let pp_step = Irmin.Type.pp S.Path.step_t in + let pp ppf (s, k) = + match S.Tree.destruct k with + | `Contents _ -> Fmt.pf ppf "FILE %a" pp_step s + | `Node _ -> Fmt.pf ppf "DIR %a" pp_step s + in + List.iter (print "%a" pp) paths in Term.(mk list $ store () $ path_or_empty)); } @@ -194,52 +198,49 @@ let tree = term = (let tree (S (impl, store, _)) = let (module S) = Store.Impl.generic_keyed impl in - run - (let* t = store in - let all = ref [] in - let todo = ref [ S.Path.empty ] in - let rec walk () = - match !todo with - | [] -> Lwt.return_unit - | k :: rest -> - todo := rest; - let* childs = S.list t k in - Lwt_list.iter_p - (fun (s, c) -> - let k = S.Path.rcons k s in - match S.Tree.destruct c with - | `Node _ -> - todo := k :: !todo; - Lwt.return_unit - | `Contents _ -> - let+ v = S.get t k in - all := (k, v) :: !all) - childs - >>= walk - in - walk () >>= fun () -> - let all = !all in - let all = - List.map - (fun (k, v) -> - ( Irmin.Type.to_string S.Path.t k, - Irmin.Type.to_string S.Contents.t v )) - all - in - let max_length l = - List.fold_left (fun len s -> max len (String.length s)) 0 l - in - let k_max = max_length (List.map fst all) in - let v_max = max_length (List.map snd all) in - let pad = 79 + k_max + v_max in - List.iter - (fun (k, v) -> - let dots = - String.make (pad - String.length k - String.length v) '.' - in - print "%s%s%s" k dots v) - all; - Lwt.return_unit) + run @@ fun () -> + let t = store () in + let all = ref [] in + let todo = ref [ S.Path.empty ] in + let rec walk () = + match !todo with + | [] -> () + | k :: rest -> + todo := rest; + let childs = S.list t k in + List.iter + (fun (s, c) -> + let k = S.Path.rcons k s in + match S.Tree.destruct c with + | `Node _ -> todo := k :: !todo + | `Contents _ -> + let v = S.get t k in + all := (k, v) :: !all) + childs; + walk () + in + walk (); + let all = !all in + let all = + List.map + (fun (k, v) -> + ( Irmin.Type.to_string S.Path.t k, + Irmin.Type.to_string S.Contents.t v )) + all + in + let max_length l = + List.fold_left (fun len s -> max len (String.length s)) 0 l + in + let k_max = max_length (List.map fst all) in + let v_max = max_length (List.map snd all) in + let pad = 79 + k_max + v_max in + List.iter + (fun (k, v) -> + let dots = + String.make (pad - String.length k - String.length v) '.' + in + print "%s%s%s" k dots v) + all in Term.(mk tree $ store ())); } @@ -265,12 +266,12 @@ let set = in let set (S (impl, store, _)) author message path v = let (module S) = Store.Impl.generic_keyed impl in - run - (let message = match message with Some s -> s | None -> "set" in - let* t = store in - let path = key S.Path.t path in - let value = value S.Contents.t v in - S.set_exn t ~info:(info (module S) ?author "%s" message) path value) + run @@ fun () -> + let message = match message with Some s -> s | None -> "set" in + let t = store () in + let path = key S.Path.t path in + let value = value S.Contents.t v in + S.set_exn t ~info:(info (module S) ?author "%s" message) path value in Term.(mk set $ store () $ author $ message $ path $ v)); } @@ -284,23 +285,23 @@ let remove = term = (let remove (S (impl, store, _)) author message path = let (module S) = Store.Impl.generic_keyed impl in - run - (let message = - match message with Some s -> s | None -> "remove " ^ path - in - let* t = store in - S.remove_exn t - ~info:(info (module S) ?author "%s" message) - (key S.Path.t path)) + run @@ fun () -> + let message = + match message with Some s -> s | None -> "remove " ^ path + in + let t = store () in + S.remove_exn t + ~info:(info (module S) ?author "%s" message) + (key S.Path.t path) in Term.(mk remove $ store () $ author $ message $ path)); } let apply e f = match (e, f) with - | R (h, e), Some f -> f ?ctx:None ?headers:h e + | R (h, e), Some f -> f ?ctx:None ?headers:h e () | R _, None -> Fmt.failwith "invalid remote for that kind of store" - | r, _ -> Lwt.return r + | r, _ -> r (* CLONE *) let clone = @@ -312,16 +313,16 @@ let clone = (let clone (S (impl, store, f), remote) depth = let (module S) = Store.Impl.generic_keyed impl in let module Sync = Irmin.Sync.Make (S) in - run - (let* t = store in - let* r = remote in - let* x = apply r f in - Sync.fetch t ?depth x >>= function - | Ok (`Head d) -> S.Head.set t d - | Ok `Empty -> Lwt.return_unit - | Error (`Msg e) -> failwith e) - in - Term.(mk clone $ remote () $ depth)); + run @@ fun () -> + let t = store () in + let r = remote () in + let x = apply r f in + match Sync.fetch t ?depth x with + | Ok (`Head d) -> S.Head.set t d + | Ok `Empty -> () + | Error (`Msg e) -> failwith e + in + Term.(mk clone $ Resolver.remote () $ depth)); } (* FETCH *) @@ -334,16 +335,16 @@ let fetch = (let fetch (S (impl, store, f), remote) = let (module S) = Store.Impl.generic_keyed impl in let module Sync = Irmin.Sync.Make (S) in - run - (let* t = store in - let* r = remote in - let branch = branch S.Branch.t "import" in - let* t = S.of_branch (S.repo t) branch in - let* x = apply r f in - let* _ = Sync.pull_exn t x `Set in - Lwt.return_unit) - in - Term.(mk fetch $ remote ())); + run @@ fun () -> + let t = store () in + let r = remote () in + let branch = branch S.Branch.t "import" in + let t = S.of_branch (S.repo t) branch in + let x = apply r f in + let _ = Sync.pull_exn t x `Set in + () + in + Term.(mk fetch $ Resolver.remote ())); } (* MERGE *) @@ -355,21 +356,22 @@ let merge = term = (let merge (S (impl, store, _)) author message branch = let (module S) = Store.Impl.generic_keyed impl in - run - (let message = match message with Some s -> s | None -> "merge" in - let branch = - match Irmin.Type.of_string S.Branch.t branch with - | Ok b -> b - | Error (`Msg msg) -> failwith msg - in - let* t = store in - S.merge_with_branch t branch - ~info:(info (module S) ?author "%s" message) - >|= function - | Ok () -> () - | Error conflict -> - let fmt = Irmin.Type.pp_json Irmin.Merge.conflict_t in - Fmt.epr "CONFLICT: %a\n%!" fmt conflict) + run @@ fun () -> + let message = match message with Some s -> s | None -> "merge" in + let branch = + match Irmin.Type.of_string S.Branch.t branch with + | Ok b -> b + | Error (`Msg msg) -> failwith msg + in + let t = store () in + match + S.merge_with_branch t branch + ~info:(info (module S) ?author "%s" message) + with + | Ok () -> () + | Error conflict -> + let fmt = Irmin.Type.pp_json Irmin.Merge.conflict_t in + Fmt.epr "CONFLICT: %a\n%!" fmt conflict in let branch_name = let doc = Arg.info ~docv:"BRANCH" ~doc:"Branch to merge from." [] in @@ -389,14 +391,14 @@ let pull = let (module S) = Store.Impl.generic_keyed impl in let message = match message with Some s -> s | None -> "pull" in let module Sync = Irmin.Sync.Make (S) in - run - (let* t = store in - let* r = remote in - let* x = apply r f in - let* _ = - Sync.pull_exn t x (`Merge (info (module S) ?author "%s" message)) - in - Lwt.return_unit) + run @@ fun () -> + let t = store () in + let r = remote () in + let x = apply r f in + let _ = + Sync.pull_exn t x (`Merge (info (module S) ?author "%s" message)) + in + () in Term.(mk pull $ remote () $ author $ message)); } @@ -411,12 +413,12 @@ let push = (let push (S (impl, store, f), remote) = let (module S) = Store.Impl.generic_keyed impl in let module Sync = Irmin.Sync.Make (S) in - run - (let* t = store in - let* r = remote in - let* x = apply r f in - let* _ = Sync.push_exn t x in - Lwt.return_unit) + run @@ fun () -> + let t = store () in + let r = remote () in + let x = apply r f in + let _ = Sync.push_exn t x in + () in Term.(mk push $ remote ())); } @@ -430,11 +432,11 @@ let snapshot = term = (let snapshot (S (impl, store, _)) = let (module S) = Store.Impl.generic_keyed impl in - run - (let* t = store in - let* k = S.Head.get t in - print "%a" S.Commit.pp_hash k; - Lwt.return_unit) + run @@ fun () -> + let t = store () in + let k = S.Head.get t in + print "%a" S.Commit.pp_hash k; + () in Term.(mk snapshot $ store ())); } @@ -454,13 +456,12 @@ let revert = in let revert (S (impl, store, _)) snapshot = let (module S) = Store.Impl.generic_keyed impl in - run - (let* t = store in - let hash = commit S.Hash.t snapshot in - let* s = S.Commit.of_hash (S.repo t) hash in - match s with - | Some s -> S.Head.set t s - | None -> failwith "invalid commit") + run @@ fun () -> + let t = store () in + let hash = commit S.Hash.t snapshot in + match S.Commit.of_hash (S.repo t) hash with + | Some s -> S.Head.set t s + | None -> failwith "invalid commit" in Term.(mk revert $ store () $ snapshot)); } @@ -519,9 +520,11 @@ let handle_diff (type a b) (module S : Irmin.Generic_key.S with type Schema.Path.t = a and type commit = b) (path : a) command proc d = + Lwt_eio.run_lwt @@ fun () -> let view (c, _) = - let* t = S.of_commit c in - S.find_tree t path >|= function None -> S.Tree.empty () | Some v -> v + Lwt_eio.run_eio @@ fun () -> + let t = S.of_commit c in + match S.find_tree t path with None -> S.Tree.empty () | Some v -> v in let* x, y = match d with @@ -537,7 +540,7 @@ let handle_diff (type a b) (x, S.Tree.empty ()) in let* (diff : (S.path * (S.contents * S.metadata) Irmin.Diff.t) list) = - S.Tree.diff x y + Lwt_eio.run_eio @@ fun () -> S.Tree.diff x y in run_command (module S : Irmin.Generic_key.S @@ -560,18 +563,17 @@ let watch = at_exit (fun () -> match !proc with None -> () | Some p -> p#terminate) in - run - (let* t = store in - let* _ = - S.watch_key t path - (handle_diff - (module S : Irmin.Generic_key.S - with type Schema.Path.t = S.path - and type commit = S.commit) - path command proc) - in - let t, _ = Lwt.task () in - t) + run @@ fun () -> + let t = store () in + let _ = + S.watch_key t path + (handle_diff + (module S : Irmin.Generic_key.S + with type Schema.Path.t = S.path + and type commit = S.commit) + path command proc) + in + () in let command = let doc = Arg.info ~docv:"COMMAND" ~doc:"Command to execute" [] in @@ -620,33 +622,28 @@ let dot = Printf.sprintf "%2d:%2d:%2d" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec in - run - (let* t = store in - let call_dot = not no_dot_call in - let buf = Buffer.create 1024 in - Dot.output_buffer ~html:false t ?depth ~full ~date buf >>= fun () -> - let oc = open_out_bin (basename ^ ".dot") in - let* () = - Lwt.finalize - (fun () -> - output_string oc (Buffer.contents buf); - Lwt.return_unit) - (fun () -> - close_out oc; - Lwt.return_unit) - in - if call_dot then ( - let i = Sys.command "/bin/sh -c 'command -v dot'" in - if i <> 0 then - [%logs.err - "Cannot find the `dot' utility. Please install it on your \ - system and be sure it is available in your $PATH."]; - let i = - Sys.command - (Printf.sprintf "dot -Tpng %s.dot -o%s.png" basename basename) - in - if i <> 0 then [%logs.err "The %s.dot is corrupted" basename]); - Lwt.return_unit) + run @@ fun () -> + let t = store () in + let call_dot = not no_dot_call in + let buf = Buffer.create 1024 in + let () = Dot.output_buffer ~html:false t ?depth ~full ~date buf in + let oc = open_out_bin (basename ^ ".dot") in + let () = + Fun.protect + (fun () -> output_string oc (Buffer.contents buf)) + ~finally:(fun () -> close_out oc) + in + if call_dot then ( + let i = Sys.command "/bin/sh -c 'command -v dot'" in + if i <> 0 then + [%logs.err + "Cannot find the `dot' utility. Please install it on your \ + system and be sure it is available in your $PATH."]; + let i = + Sys.command + (Printf.sprintf "dot -Tpng %s.dot -o%s.png" basename basename) + in + if i <> 0 then [%logs.err "The %s.dot is corrupted" basename]) in Term.(mk dot $ store () $ basename $ depth $ no_dot_call $ full)); } @@ -737,24 +734,25 @@ let graphql = in let graphql (S (impl, store, remote_fn)) port addr = let (module S) = Store.Impl.generic_keyed impl in - run - (let module Server = - Graphql.Server.Make - (S) - (struct - let remote = remote_fn - end) - in - let* t = store in - let server = Server.v (S.repo t) in - let* ctx = Conduit_lwt_unix.init ~src:addr () in - let ctx = Cohttp_lwt_unix.Net.init ~ctx () in - let on_exn exn = - [%logs.debug "on_exn: %s" (Printexc.to_string exn)] - in - Cohttp_lwt_unix.Server.create ~on_exn ~ctx - ~mode:(`TCP (`Port port)) - server) + run @@ fun () -> + let module Server = + Graphql.Server.Make + (S) + (struct + let remote = remote_fn + end) + in + let t = store () in + let server = Server.v (S.repo t) in + let ctx = + Lwt_eio.run_lwt @@ fun () -> Conduit_lwt_unix.init ~src:addr () + in + let ctx = Cohttp_lwt_unix.Net.init ~ctx () in + let on_exn exn = [%logs.debug "on_exn: %s" (Printexc.to_string exn)] in + Lwt_eio.run_lwt @@ fun () -> + Cohttp_lwt_unix.Server.create ~on_exn ~ctx + ~mode:(`TCP (`Port port)) + server in Term.(mk graphql $ store () $ port $ addr)); } @@ -803,10 +801,10 @@ let branches = term = (let branches (S (impl, store, _)) = let (module S) = Store.Impl.generic_keyed impl in - run - (let* t = store in - let+ branches = S.Branch.list (S.repo t) in - List.iter (Fmt.pr "%a\n" (Irmin.Type.pp S.branch_t)) branches) + run @@ fun () -> + let t = store () in + let branches = S.Branch.list (S.repo t) in + List.iter (Fmt.pr "%a\n" (Irmin.Type.pp S.branch_t)) branches in Term.(mk branches $ store ())); } @@ -869,59 +867,55 @@ let log = let exception Return in let commits (S (impl, store, _)) plain pager num skip reverse = let (module S) = Store.Impl.generic_keyed impl in - run - (let* t = store in - let fmt f date = - Fmt.pf f "%s %s %02d %02d:%02d:%02d %04d" (weekday date) - (month date) date.tm_mday date.tm_hour date.tm_min date.tm_sec - (date.tm_year + 1900) - in - let repo = S.repo t in - let skip = ref (Option.value ~default:0 skip) in - let num = Option.value ~default:0 num in - let num_count = ref 0 in - let commit formatter key = - if num > 0 && !num_count >= num then raise Return - else if !skip > 0 then - let () = decr skip in - Lwt.return_unit - else - let+ commit = S.Commit.of_key repo key >|= Option.get in - let hash = S.Backend.Commit.Key.to_hash key in - let info = S.Commit.info commit in - let date = S.Info.date info in - let author = S.Info.author info in - let message = S.Info.message info in - let date = Unix.localtime (Int64.to_float date) in - let () = - Fmt.pf formatter "commit %a\nAuthor: %s\nDate: %a\n\n%s\n\n%!" - (Irmin.Type.pp S.hash_t) hash author fmt date message - in - incr num_count - in - let* max = S.Head.get t >|= fun x -> [ `Commit (S.Commit.key x) ] in - let iter ~commit ~max repo = - Lwt.catch - (fun () -> - if reverse then S.Repo.iter ~commit ~min:[] ~max repo - else S.Repo.breadth_first_traversal ~commit ~max repo) - (function Return -> Lwt.return_unit | exn -> raise exn) - in - if plain then - let commit = commit Format.std_formatter in - iter ~commit ~max repo - else - Lwt.catch - (fun () -> - let out = Unix.open_process_out pager in - let commit = commit (Format.formatter_of_out_channel out) in - let+ () = iter ~commit ~max repo in - let _ = Unix.close_process_out out in - ()) - (function - | Sys_error s when String.equal s "Broken pipe" -> - Lwt.return_unit - | exn -> raise exn)) + run @@ fun () -> + let t = store () in + let fmt f date = + Fmt.pf f "%s %s %02d %02d:%02d:%02d %04d" (weekday date) (month date) + date.tm_mday date.tm_hour date.tm_min date.tm_sec + (date.tm_year + 1900) + in + let repo = S.repo t in + let skip = ref (Option.value ~default:0 skip) in + let num = Option.value ~default:0 num in + let num_count = ref 0 in + let commit formatter key = + if num > 0 && !num_count >= num then raise Return + else if !skip > 0 then decr skip + else + let commit = S.Commit.of_key repo key |> Option.get in + let hash = S.Backend.Commit.Key.to_hash key in + let info = S.Commit.info commit in + let date = S.Info.date info in + let author = S.Info.author info in + let message = S.Info.message info in + let date = Unix.localtime (Int64.to_float date) in + let () = + Fmt.pf formatter "commit %a\nAuthor: %s\nDate: %a\n\n%s\n\n%!" + (Irmin.Type.pp S.hash_t) hash author fmt date message + in + incr num_count + in + let max = + let x = S.Head.get t in + [ `Commit (S.Commit.key x) ] + in + let iter ~commit ~max repo = + try + if reverse then S.Repo.iter ~commit ~min:[] ~max repo + else S.Repo.breadth_first_traversal ~commit ~max repo + with Return -> () + in + if plain then + let commit = commit Format.std_formatter in + iter ~commit ~max repo + else + try + let out = Unix.open_process_out pager in + let commit = commit (Format.formatter_of_out_channel out) in + let () = iter ~commit ~max repo in + let _ = Unix.close_process_out out in + () + with Sys_error s when String.equal s "Broken pipe" -> () in Term.(mk commits $ store () $ plain $ pager $ num $ skip $ reverse)); } diff --git a/src/irmin-cli/dune b/src/irmin-cli/dune index 9da6421942..269c2ada7f 100644 --- a/src/irmin-cli/dune +++ b/src/irmin-cli/dune @@ -18,7 +18,9 @@ git-unix cohttp-lwt-unix unix - yaml) + yaml + lwt_eio + eio_main) (preprocess (pps ppx_irmin.internal)) (instrumentation diff --git a/src/irmin-cli/resolver.ml b/src/irmin-cli/resolver.ml index 07591bdeac..4d2106ef08 100644 --- a/src/irmin-cli/resolver.ml +++ b/src/irmin-cli/resolver.ml @@ -257,7 +257,7 @@ module Store = struct end type remote_fn = - ?ctx:Mimic.ctx -> ?headers:Cohttp.Header.t -> string -> Irmin.remote Lwt.t + ?ctx:Mimic.ctx -> ?headers:Cohttp.Header.t -> string -> unit -> Irmin.remote type t = | T : { @@ -409,7 +409,8 @@ let config_term = $ config_path_term $ Arg.(value @@ opt_all (list (pair ~sep:'=' string string)) [] opts)) -type store = S : 'a Store.Impl.t * 'a Lwt.t * Store.remote_fn option -> store +type store = + | S : 'a Store.Impl.t * (unit -> 'a) * Store.remote_fn option -> store let rec read_config_file path = let home = config_root () / global_config_path in @@ -591,16 +592,18 @@ let build_irmin_config config root opts (store, hash, contents) branch commit config) config (List.flatten opts) in - let spec = + let spec () = match (branch, commit) with | _, Some hash -> ( - S.Repo.v config >>= fun repo -> - let* commit = S.Commit.of_hash repo hash in + let repo = S.Repo.v config in + let commit = S.Commit.of_hash repo hash in match commit with | None -> invalid_arg "unknown commit" | Some c -> S.of_commit c) - | None, None -> S.Repo.v config >>= S.main - | Some b, None -> S.Repo.v config >>= fun repo -> S.of_branch repo b + | None, None -> S.Repo.v config |> S.main + | Some b, None -> + let repo = S.Repo.v config in + S.of_branch repo b in S (impl, spec, remote) @@ -674,19 +677,19 @@ let infer_remote hash contents branch headers str = Conf.add config r v | _ -> config in - let* repo = R.Repo.v config in + let repo = R.Repo.v config in let branch = match branch with | Some b -> Irmin.Type.of_string R.branch_t b |> Result.get_ok | None -> R.Branch.main in - let+ r = R.of_branch repo branch in + let r = R.of_branch repo branch in Irmin.remote_store (module R) r else let headers = match headers with [] -> None | h -> Some (Cohttp.Header.of_list h) in - Lwt.return (R (headers, str)) + R (headers, str) let remote () = let repo = @@ -702,7 +705,7 @@ let remote () = let store = build_irmin_config y root opts (store, hash, contents) branch commit None in - let remote = infer_remote hash contents branch headers str in + let remote () = infer_remote hash contents branch headers str in (store, remote) in Term.( diff --git a/src/irmin-cli/resolver.mli b/src/irmin-cli/resolver.mli index 665e2b12c1..9fbc8f637f 100644 --- a/src/irmin-cli/resolver.mli +++ b/src/irmin-cli/resolver.mli @@ -60,7 +60,7 @@ module Store : sig end type remote_fn = - ?ctx:Mimic.ctx -> ?headers:Cohttp.Header.t -> string -> Irmin.remote Lwt.t + ?ctx:Mimic.ctx -> ?headers:Cohttp.Header.t -> string -> unit -> Irmin.remote type t (** The type for store configurations. A configuration value contains: the @@ -123,12 +123,13 @@ val load_config : The values provided for [store], [hash] and [contents] will be used by default if no other value is found in the config file *) -type store = S : 'a Store.Impl.t * 'a Lwt.t * Store.remote_fn option -> store +type store = + | S : 'a Store.Impl.t * (unit -> 'a) * Store.remote_fn option -> store val store : unit -> store Cmdliner.Term.t (** Parse the command-line arguments and then the config file. *) type Irmin.remote += R of Cohttp.Header.t option * string -val remote : unit -> (store * Irmin.remote Lwt.t) Cmdliner.Term.t +val remote : unit -> (store * (unit -> Irmin.remote)) Cmdliner.Term.t (** Parse a remote store location. *) diff --git a/src/irmin-git/unix/dune b/src/irmin-git/unix/dune index 3947e48d5d..b99c2c26d5 100644 --- a/src/irmin-git/unix/dune +++ b/src/irmin-git/unix/dune @@ -1,7 +1,7 @@ (library (public_name irmin-git.unix) (name irmin_git_unix) - (libraries cohttp-lwt-unix git-unix irmin-git irmin.unix lwt.unix) + (libraries cohttp-lwt-unix git-unix irmin-git irmin.unix lwt.unix lwt_eio) (preprocess (pps ppx_irmin.internal)) (instrumentation diff --git a/src/irmin-git/unix/xgit.ml b/src/irmin-git/unix/xgit.ml index 4b8489b877..d9c663b4fc 100644 --- a/src/irmin-git/unix/xgit.ml +++ b/src/irmin-git/unix/xgit.ml @@ -21,7 +21,8 @@ let src = Logs.Src.create "git.unix" ~doc:"logs git's unix events" module Log = (val Logs.src_log src : Logs.LOG) -let remote ?ctx ?headers uri = +let remote ?ctx ?headers uri () = + Lwt_eio.run_lwt @@ fun () -> let+ ctx = match ctx with | Some x -> Lwt.return x @@ -58,24 +59,24 @@ module Maker (G : Irmin_git.G) = struct struct include Maker.S.Make (S) - let remote ?ctx ?headers uri = - let+ e = remote ?ctx ?headers uri in + let remote ?ctx ?headers uri () = + let e = remote ?ctx ?headers uri () in E e end module KV (C : Irmin.Contents.S) = struct include Maker.KV.Make (C) - let remote ?ctx ?headers uri = - let+ e = remote ?ctx ?headers uri in + let remote ?ctx ?headers uri () = + let e = remote ?ctx ?headers uri () in E e end module Ref (C : Irmin.Contents.S) = struct include Maker.Ref.Make (C) - let remote ?ctx ?headers uri = - let+ e = remote ?ctx ?headers uri in + let remote ?ctx ?headers uri () = + let e = remote ?ctx ?headers uri () in E e end end diff --git a/src/irmin-git/unix/xgit_intf.ml b/src/irmin-git/unix/xgit_intf.ml index dcaa9b4f21..d4674781ea 100644 --- a/src/irmin-git/unix/xgit_intf.ml +++ b/src/irmin-git/unix/xgit_intf.ml @@ -26,7 +26,7 @@ module type S = sig with type Backend.Remote.endpoint = Mimic.ctx * Smart_git.Endpoint.t val remote : - ?ctx:Mimic.ctx -> ?headers:Cohttp.Header.t -> string -> Irmin.remote Lwt.t + ?ctx:Mimic.ctx -> ?headers:Cohttp.Header.t -> string -> unit -> Irmin.remote end module type Backend = sig diff --git a/src/irmin-graphql/server.ml b/src/irmin-graphql/server.ml index 5b61253194..3b966c83f4 100644 --- a/src/irmin-graphql/server.ml +++ b/src/irmin-graphql/server.ml @@ -53,7 +53,8 @@ end module type CONFIG = sig type info - val remote : (?headers:Cohttp.Header.t -> string -> Irmin.remote Lwt.t) option + val remote : + (?headers:Cohttp.Header.t -> string -> unit -> Irmin.remote) option val info : ?author:string -> ('a, Format.formatter, unit, unit -> info) format4 -> 'a @@ -516,7 +517,7 @@ struct ~resolve:(fun _ _src branch remote -> Lwt_eio.run_eio @@ fun () -> let t = mk_branch s branch in - let remote = Lwt_eio.run_lwt @@ fun () -> remote in + let remote = remote () in match Sync.fetch t remote with | Ok (`Head d) -> Store.Head.set t d |> fun () -> Ok (Some d) | Ok `Empty -> Ok None @@ -532,7 +533,7 @@ struct ~resolve:(fun _ _src branch remote depth -> Lwt_eio.run_eio @@ fun () -> let t = mk_branch s branch in - let remote = Lwt_eio.run_lwt @@ fun () -> remote in + let remote = remote () in match Sync.push t ?depth remote with | Ok (`Head commit) -> Ok (Some commit) | Ok `Empty -> Ok None @@ -558,7 +559,7 @@ struct `Merge info | None -> `Set in - let remote = Lwt_eio.run_lwt @@ fun () -> remote in + let remote = remote () in match Sync.pull ?depth t remote strategy with | Ok (`Head h) -> Ok (Some h) | Ok `Empty -> Ok None diff --git a/src/irmin-graphql/server.mli b/src/irmin-graphql/server.mli index 4bdc904ef2..706f785bbd 100644 --- a/src/irmin-graphql/server.mli +++ b/src/irmin-graphql/server.mli @@ -42,7 +42,8 @@ end module type CONFIG = sig type info - val remote : (?headers:Cohttp.Header.t -> string -> Irmin.remote Lwt.t) option + val remote : + (?headers:Cohttp.Header.t -> string -> unit -> Irmin.remote) option val info : ?author:string -> ('a, Format.formatter, unit, unit -> info) format4 -> 'a diff --git a/src/irmin-graphql/unix/irmin_graphql_unix.ml b/src/irmin-graphql/unix/irmin_graphql_unix.ml index 442494325c..6d050a8256 100644 --- a/src/irmin-graphql/unix/irmin_graphql_unix.ml +++ b/src/irmin-graphql/unix/irmin_graphql_unix.ml @@ -15,7 +15,7 @@ *) type remote_fn = - ?ctx:Mimic.ctx -> ?headers:Cohttp.Header.t -> string -> Irmin.remote Lwt.t + ?ctx:Mimic.ctx -> ?headers:Cohttp.Header.t -> string -> unit -> Irmin.remote module Server = struct module Remote = struct diff --git a/src/irmin-graphql/unix/irmin_graphql_unix.mli b/src/irmin-graphql/unix/irmin_graphql_unix.mli index fc286e5cc1..1d007ab197 100644 --- a/src/irmin-graphql/unix/irmin_graphql_unix.mli +++ b/src/irmin-graphql/unix/irmin_graphql_unix.mli @@ -15,7 +15,7 @@ *) type remote_fn = - ?ctx:Mimic.ctx -> ?headers:Cohttp.Header.t -> string -> Irmin.remote Lwt.t + ?ctx:Mimic.ctx -> ?headers:Cohttp.Header.t -> string -> unit -> Irmin.remote module Server : sig module Remote : sig diff --git a/test/irmin-cli/test.ml b/test/irmin-cli/test.ml index 8f777bb7c8..01123ad540 100644 --- a/test/irmin-cli/test.ml +++ b/test/irmin-cli/test.ml @@ -32,11 +32,10 @@ module Conf = struct "Spec name" "pack" (Irmin.Backend.Conf.Spec.name spec); Alcotest.(check int) "index-log-size" 1234 index_log_size; - Alcotest.(check bool) "fresh" true fresh; - Lwt.return_unit + Alcotest.(check bool) "fresh" true fresh let misc : unit Alcotest.test_case list = - [ ("config", `Quick, fun () -> Lwt_main.run (test_config ())) ] + [ ("config", `Quick, fun () -> test_config ()) ] end let () = Alcotest.run "irmin-cli" [ ("conf", Conf.misc) ] From 331095b709a2e7e41713c09cbc14770f167c5405 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Fri, 2 Jun 2023 17:20:10 +0200 Subject: [PATCH 22/99] Fix irmin-mirage using lwt_eio --- src/irmin-mirage/git/irmin_mirage_git.ml | 121 +++++++++--------- .../graphql/irmin_mirage_graphql.ml | 3 +- 2 files changed, 64 insertions(+), 60 deletions(-) diff --git a/src/irmin-mirage/git/irmin_mirage_git.ml b/src/irmin-mirage/git/irmin_mirage_git.ml index e02187b87c..34980b2c69 100644 --- a/src/irmin-mirage/git/irmin_mirage_git.ml +++ b/src/irmin-mirage/git/irmin_mirage_git.ml @@ -14,7 +14,6 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Lwt.Infix include Irmin_mirage_git_intf let remote ?(ctx = Mimic.empty) ?headers uri = @@ -109,14 +108,14 @@ module KV_RO (G : Git.S) = struct type t = { repo : S.repo; tree : S.tree } let digest t key = - S.Tree.find_tree t.tree (path key) >|= function + match S.Tree.find_tree t.tree (path key) with | None -> err_not_found key | Some tree -> let h = S.Tree.hash tree in Ok (Irmin.Type.to_string S.Hash.t h) let list t key = - S.Tree.list t.tree (path key) >|= fun l -> + let l = S.Tree.list t.tree (path key) in let l = List.map (fun (s, k) -> @@ -129,13 +128,13 @@ module KV_RO (G : Git.S) = struct Ok l let exists t key = - S.Tree.kind t.tree (path key) >|= function + match S.Tree.kind t.tree (path key) with | Some `Contents -> Ok (Some `Value) | Some `Node -> Ok (Some `Dictionary) | None -> Ok None let get t key = - S.Tree.find t.tree (path key) >|= function + match S.Tree.find t.tree (path key) with | None -> err_not_found key | Some v -> Ok v @@ -159,7 +158,7 @@ module KV_RO (G : Git.S) = struct type t = { root : S.path; t : S.t } let head_message t = - S.Head.find t.t >|= function + match S.Head.find t.t with | None -> "empty HEAD" | Some h -> let info = S.Commit.info h in @@ -168,36 +167,39 @@ module KV_RO (G : Git.S) = struct let last_modified t key = let key' = path key in - S.last_modified t.t key' >|= function + match S.last_modified t.t key' with | [] -> Error (`Not_found key) | h :: _ -> Ok (Ptime.v (0, S.Info.date (S.Commit.info h))) let connect ?depth ?(branch = "main") ?(root = Mirage_kv.Key.empty) ?ctx ?headers t uri = + Lwt_eio.run_eio @@ fun () -> let remote = S.remote ?ctx ?headers uri in let head = Git.Reference.v ("refs/heads/" ^ branch) in - S.repo_of_git ~bare:true ~head t >>= fun repo -> - S.of_branch repo branch >>= fun t -> - Sync.pull_exn t ?depth remote `Set >|= fun _ -> + let repo = S.repo_of_git ~bare:true ~head t in + let t = S.of_branch repo branch in + let _ = Sync.pull_exn t ?depth remote `Set in let root = path root in { t; root } let tree t = let repo = S.repo t.t in - (S.find_tree t.t t.root >|= function - | None -> S.Tree.empty () - | Some tree -> tree) - >|= fun tree -> { Tree.repo; tree } + let tree = + match S.find_tree t.t t.root with + | None -> S.Tree.empty () + | Some tree -> tree + in + { Tree.repo; tree } - let exists t k = tree t >>= fun t -> Tree.exists t k - let get t k = tree t >>= fun t -> Tree.get t k + let exists t k = Tree.exists (tree t) k + let get t k = Tree.get (tree t) k let get_partial t k ~offset ~length = Lwt_eio.run_eio @@ fun () -> Tree.get_partial (tree t) k ~offset ~length - let list t k = tree t >>= fun t -> Tree.list t k - let digest t k = tree t >>= fun t -> Tree.digest t k - let size t k = tree t >>= fun t -> Tree.size t k + let list t k = Tree.list (tree t) k + let digest t k = Tree.digest (tree t) k + let size t k = Tree.size (tree t) k let get t k = match Key.segments k with [ "HEAD" ] -> Ok (head_message t) | _ -> get t k @@ -245,7 +247,8 @@ module KV_RW (G : Irmin_git.G) (C : Mirage_clock.PCLOCK) = struct let connect ?depth ?branch ?root ?ctx ?headers ?(author = default_author) ?(msg = default_msg) git uri = - RO.connect ?depth ?branch ?root ?ctx ?headers git uri >|= fun t -> + let open Lwt.Syntax in + let+ t = RO.connect ?depth ?branch ?root ?ctx ?headers git uri in let remote = S.remote ?ctx ?headers uri in { store = Store t; author; msg; remote } @@ -258,7 +261,7 @@ module KV_RW (G : Irmin_git.G) (C : Mirage_clock.PCLOCK) = struct match t.store with | Store t -> RO.last_modified t key | Batch b -> - RO.S.of_commit b.origin >>= fun t -> + let t = RO.S.of_commit b.origin in RO.last_modified { root = S.Path.empty; t } key let repo t = match t.store with Store t -> S.repo t.t | Batch b -> b.repo @@ -266,17 +269,17 @@ module KV_RW (G : Irmin_git.G) (C : Mirage_clock.PCLOCK) = struct let tree t = match t.store with | Store t -> RO.tree t - | Batch b -> Lwt.return { Tree.tree = b.tree; repo = repo t } + | Batch b -> { Tree.tree = b.tree; repo = repo t } - let digest t k = tree t >>= fun t -> Tree.digest t k - let size t k = tree t >>= fun t -> Tree.size t k - let exists t k = tree t >>= fun t -> Tree.exists t k - let get t k = tree t >>= fun t -> Tree.get t k + let digest t k = Lwt_eio.run_eio @@ fun () -> Tree.digest (tree t) k + let size t k = Lwt_eio.run_eio @@ fun () -> Tree.size (tree t) k + let exists t k = Lwt_eio.run_eio @@ fun () -> Tree.exists (tree t) k + let get t k = Lwt_eio.run_eio @@ fun () -> Tree.get (tree t) k let get_partial t k ~offset ~length = - tree t >>= fun t -> Tree.get_partial t k ~offset ~length + Lwt_eio.run_eio @@ fun () -> Tree.get_partial (tree t) k ~offset ~length - let list t k = tree t >>= fun t -> Tree.list t k + let list t k = Lwt_eio.run_eio @@ fun () -> Tree.list (tree t) k type write_error = [ RO.error | Mirage_kv.write_error | RO.Sync.push_error ] @@ -301,11 +304,12 @@ module KV_RW (G : Irmin_git.G) (C : Mirage_clock.PCLOCK) = struct Lwt_eio.run_eio @@ fun () -> let info = info t (`Set k) in match t.store with - | Store s -> - S.set ~info s.t (path k) v >?= fun () -> - RO.Sync.push s.t t.remote >?= fun _ -> Lwt.return_ok () + | Store s -> ( + match S.set ~info s.t (path k) v with + | Ok _ -> RO.Sync.push s.t t.remote |> write_error + | Error e -> Error (e :> write_error)) | Batch b -> - S.Tree.add b.tree (path k) v >|= fun tree -> + let tree = S.Tree.add b.tree (path k) v in b.tree <- tree; Ok () @@ -325,11 +329,12 @@ module KV_RW (G : Irmin_git.G) (C : Mirage_clock.PCLOCK) = struct Lwt_eio.run_eio @@ fun () -> let info = info t (`Remove k) in match t.store with - | Store s -> - S.remove ~info s.t (path k) >?= fun () -> - RO.Sync.push s.t t.remote >?= fun _ -> Lwt.return_ok () + | Store s -> ( + match S.remove ~info s.t (path k) with + | Ok _ -> RO.Sync.push s.t t.remote |> write_error + | Error e -> Error (e :> write_error)) | Batch b -> - S.Tree.remove b.tree (path k) >|= fun tree -> + let tree = S.Tree.remove b.tree (path k) in b.tree <- tree; Ok () @@ -346,11 +351,11 @@ module KV_RW (G : Irmin_git.G) (C : Mirage_clock.PCLOCK) = struct | None -> set t k (String.make size '\000') let get_store_tree (t : RO.t) = - S.Head.find t.t >>= function - | None -> Lwt.return_none + match S.Head.find t.t with + | None -> None | Some origin -> ( let tree = S.Commit.tree origin in - S.Tree.find_tree tree t.root >|= function + match S.Tree.find_tree tree t.root with | Some t -> Some (origin, t) | None -> Some (origin, S.Tree.empty ())) @@ -362,41 +367,39 @@ module KV_RW (G : Irmin_git.G) (C : Mirage_clock.PCLOCK) = struct | Store s -> ( let repo = S.repo s.t in (* get the tree origin *) - get_store_tree s >>= function - | None -> f t >|= fun x -> Ok x (* no transaction is needed *) + match get_store_tree s with + | None -> Ok (f t) (* no transaction is needed *) | Some (origin, old_tree) -> ( let batch = { repo; tree = old_tree; origin } in let b = Batch batch in - f { t with store = b } >>= fun result -> - get_store_tree s >>= function + let result = f { t with store = b } in + match get_store_tree s with | None -> (* Someting weird happened, retring *) - Lwt.return (Error `Retry) + Error `Retry | Some (_, main_tree) -> ( - Irmin.Merge.f S.Tree.merge - ~old:(Irmin.Merge.promise old_tree) - main_tree batch.tree - >>= function - | Error (`Conflict _) -> Lwt.return (Error `Retry) + match + Irmin.Merge.f S.Tree.merge + ~old:(Irmin.Merge.promise old_tree) + main_tree batch.tree + with + | Error (`Conflict _) -> Error `Retry | Ok new_tree -> ( - S.set_tree s.t ~info s.root new_tree >|= function + match S.set_tree s.t ~info s.root new_tree with | Ok () -> Ok result | Error _ -> Error `Retry)))) in let rec loop = function - | 0 -> Lwt.fail_with "Too many retries" - | n -> ( - one t >>= function - | Error `Retry -> loop (n - 1) - | Ok r -> Lwt.return r) + | 0 -> failwith "Too many retries" + | n -> ( match one t with Error `Retry -> loop (n - 1) | Ok r -> r) in - loop retries >>= fun r -> + let r = loop retries in match t.store with | Batch _ -> Fmt.failwith "No recursive batches" | Store s -> ( - RO.Sync.push s.t t.remote >>= function - | Ok _ -> Lwt.return r - | Error e -> Lwt.fail_with (Fmt.to_to_string RO.Sync.pp_push_error e)) + match RO.Sync.push s.t t.remote with + | Ok _ -> r + | Error e -> failwith (Fmt.to_to_string RO.Sync.pp_push_error e)) end module Mem = struct diff --git a/src/irmin-mirage/graphql/irmin_mirage_graphql.ml b/src/irmin-mirage/graphql/irmin_mirage_graphql.ml index d582b40676..4554ca8b4c 100644 --- a/src/irmin-mirage/graphql/irmin_mirage_graphql.ml +++ b/src/irmin-mirage/graphql/irmin_mirage_graphql.ml @@ -44,7 +44,8 @@ module Server = struct let remote = Some - (fun ?headers uri -> + (fun ?headers uri () -> + Lwt_eio.run_lwt @@ fun () -> let ( ! ) f a b = f b a in let headers = Option.map Cohttp.Header.to_list headers in match Smart_git.Endpoint.of_string uri with From 1a5f58aeab2a944b4fa02d56b5fd81d0ab081161 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Fri, 2 Jun 2023 18:01:05 +0200 Subject: [PATCH 23/99] Fix examples using lwt_eio --- examples/custom_graphql.ml | 7 +++- examples/custom_merge.ml | 43 ++++++++++----------- examples/custom_storage.ml | 49 ++++++++++++------------ examples/deploy.ml | 76 +++++++++++++++++-------------------- examples/dune | 4 +- examples/fold.ml | 59 +++++++++++++--------------- examples/irmin_git_store.ml | 34 +++++++++-------- examples/process.ml | 58 +++++++++++++--------------- examples/push.ml | 30 +++++++-------- examples/readme.ml | 19 ++++------ examples/sync.ml | 24 ++++++------ examples/trees.ml | 37 +++++++++--------- 12 files changed, 212 insertions(+), 228 deletions(-) diff --git a/examples/custom_graphql.ml b/examples/custom_graphql.ml index 244cafd51f..9ab5765e80 100644 --- a/examples/custom_graphql.ml +++ b/examples/custom_graphql.ml @@ -109,14 +109,17 @@ module Server = let main () = Config.init (); let config = Irmin_git.config Config.root in - let* repo = Store.Repo.v config in + let repo = Store.Repo.v config in let server = Server.v repo in let src = "localhost" in let port = 9876 in + Lwt_eio.run_lwt @@ fun () -> let* ctx = Conduit_lwt_unix.init ~src () in let ctx = Cohttp_lwt_unix.Net.init ~ctx () in let on_exn exn = Printf.printf "on_exn: %s" (Printexc.to_string exn) in Printf.printf "Visit GraphiQL @ http://%s:%d/graphql\n%!" src port; Cohttp_lwt_unix.Server.create ~on_exn ~ctx ~mode:(`TCP (`Port port)) server -let () = Lwt_main.run (main ()) +let () = + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> main () diff --git a/examples/custom_merge.ml b/examples/custom_merge.ml index af70d47ae7..a19806cc83 100644 --- a/examples/custom_merge.ml +++ b/examples/custom_merge.ml @@ -13,7 +13,6 @@ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Lwt.Syntax open Astring let what = @@ -121,7 +120,7 @@ let info = Irmin_git_unix.info let log_file = [ "local"; "debug" ] let all_logs t = - let+ logs = Store.find t log_file in + let logs = Store.find t log_file in match logs with None -> Log.empty | Some l -> l (** Persist a new entry in the log. Pretty inefficient as it reads/writes the @@ -129,37 +128,37 @@ let all_logs t = let log t fmt = Printf.ksprintf (fun message -> - let* logs = all_logs t in + let logs = all_logs t in let logs = Log.add logs (Entry.v message) in Store.set_exn t ~info:(info "Adding a new entry") log_file logs) fmt let print_logs name t = - let+ logs = all_logs t in + let logs = all_logs t in Fmt.pr "-----------\n%s:\n-----------\n%a%!" name (Irmin.Type.pp Log.t) logs let main () = Config.init (); - let* repo = Store.Repo.v config in - let* t = Store.main repo in + let repo = Store.Repo.v config in + let t = Store.main repo in (* populate the log with some random messages *) - let* () = - Lwt_list.iter_s - (fun msg -> log t "This is my %s " msg) - [ "first"; "second"; "third" ] - in + List.iter + (fun msg -> log t "This is my %s " msg) + [ "first"; "second"; "third" ]; Printf.printf "%s\n\n" what; - let* () = print_logs "lca" t in - let* x = Store.clone ~src:t ~dst:"test" in - let* () = log x "Adding new stuff to x" in - let* () = log x "Adding more stuff to x" in - let* () = log x "More. Stuff. To x." in - let* () = print_logs "branch 1" x in - let* () = log t "I can add stuff on t also" in - let* () = log t "Yes. On t!" in - let* () = print_logs "branch 2" t in - let* r = Store.merge_into ~info:(info "Merging x into t") x ~into:t in + print_logs "lca" t; + let x = Store.clone ~src:t ~dst:"test" in + log x "Adding new stuff to x"; + log x "Adding more stuff to x"; + log x "More. Stuff. To x."; + print_logs "branch 1" x; + log t "I can add stuff on t also"; + log t "Yes. On t!"; + print_logs "branch 2" t; + let r = Store.merge_into ~info:(info "Merging x into t") x ~into:t in match r with Ok () -> print_logs "merge" t | Error _ -> failwith "conflict!" -let () = Lwt_main.run (main ()) +let () = + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> main () diff --git a/examples/custom_storage.ml b/examples/custom_storage.ml index d749e0679c..56f649a725 100644 --- a/examples/custom_storage.ml +++ b/examples/custom_storage.ml @@ -14,8 +14,6 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Lwt.Syntax - (** Create a configuration module for our storage. Here we demonstrate a simple configuration for setting the initial size of the hash table. *) @@ -44,7 +42,7 @@ functor (** Types *) - type t = { t : Value.t Tbl.t; l : Mutex.t } + type t = { t : Value.t Tbl.t; l : Eio.Mutex.t } type key = Key.t type value = Value.t @@ -52,29 +50,28 @@ functor let v config = let init_size = Irmin.Backend.Conf.get config Hashtbl_config.init_size in - { t = Tbl.create init_size; l = Mutex.create () } |> Lwt.return + { t = Tbl.create init_size; l = Eio.Mutex.create () } - let close _t = Lwt.return_unit + let close _t = () (** Operations *) - let set { t; _ } key value = Tbl.replace t key value |> Lwt.return - let mem { t; _ } key = Tbl.mem t key |> Lwt.return - let find { t; _ } key = Tbl.find_opt t key |> Lwt.return - let keys { t; _ } = Tbl.to_seq_keys t |> List.of_seq |> Lwt.return - let remove { t; _ } key = Tbl.remove t key |> Lwt.return - let clear { t; _ } = Tbl.clear t |> Lwt.return + let set { t; _ } key value = Tbl.replace t key value + let mem { t; _ } key = Tbl.mem t key + let find { t; _ } key = Tbl.find_opt t key + let keys { t; _ } = Tbl.to_seq_keys t |> List.of_seq + let remove { t; _ } key = Tbl.remove t key + let clear { t; _ } = Tbl.clear t let batch t f = - Mutex.lock t.l; - let+ x = - Lwt.catch - (fun () -> f t) - (fun exn -> - Mutex.unlock t.l; - raise exn) + Eio.Mutex.lock t.l; + let x = + try f t + with exn -> + Eio.Mutex.unlock t.l; + raise exn in - Mutex.unlock t.l; + Eio.Mutex.unlock t.l; x end @@ -90,12 +87,14 @@ let config ?(config = Hashtbl_config.empty) ?(init_size = 42) () = Irmin.Backend.Conf.add config Hashtbl_config.init_size init_size let main () = - let* repo = Store.Repo.v (config ()) in - let* main = Store.main repo in + let repo = Store.Repo.v (config ()) in + let main = Store.main repo in let info () = Store.Info.v 0L in let key = "Hello" in - let* () = Store.set_exn main [ key ] ~info "world!" in - let* v = Store.get main [ key ] in - Printf.printf "%s, %s" key v |> Lwt.return + Store.set_exn main [ key ] ~info "world!"; + let v = Store.get main [ key ] in + Printf.printf "%s, %s" key v -let () = Lwt_main.run @@ main () +let () = + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> main () diff --git a/examples/deploy.ml b/examples/deploy.ml index 384db9c071..1bbbb6cbac 100644 --- a/examples/deploy.ml +++ b/examples/deploy.ml @@ -13,7 +13,6 @@ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Lwt.Syntax module Store = Irmin_git_unix.FS.KV (Irmin.Contents.String) let config = @@ -29,12 +28,12 @@ let info ~user message () = let provision repo = Config.init (); let provision = info ~user:"Automatic VM provisioning" in - let* t = Store.of_branch repo "upstream" in + let t = Store.of_branch repo "upstream" in let v = Store.Tree.singleton [ "etc"; "manpath" ] "/usr/share/man\n/usr/local/share/man" in - let* v = + let v = Store.Tree.add v [ "bin"; "sh" ] "�����XpN ������� H__PAGEZERO(__TEXT__text__TEXT [...]" in @@ -44,49 +43,44 @@ let provision repo = let sysadmin = info ~user:"Bob the sysadmin" let configure repo = - let* t = Store.of_branch repo "upstream" in - let* () = Lwt_unix.sleep 2. in - let* t = Store.clone ~src:t ~dst:"dev" in - let* () = Lwt_unix.sleep 2. in - let* () = - Store.set_exn t - ~info:(sysadmin "DNS configuration") - [ "etc"; "resolv.conf" ] "domain mydomain.com\nnameserver 128.221.130.23" - in - let* () = Lwt_unix.sleep 2. in - let+ _ = Store.clone ~src:t ~dst:"prod" in + let t = Store.of_branch repo "upstream" in + Eio_unix.sleep 2.; + let t = Store.clone ~src:t ~dst:"dev" in + Eio_unix.sleep 2.; + Store.set_exn t + ~info:(sysadmin "DNS configuration") + [ "etc"; "resolv.conf" ] "domain mydomain.com\nnameserver 128.221.130.23"; + Eio_unix.sleep 2.; + let _ = Store.clone ~src:t ~dst:"prod" in () let attack repo = let info = info ~user:"Remote connection from 132.443.12.444" in (* 3. Attacker. *) - let* t = Store.of_branch repo "prod" in - let* () = Lwt_unix.sleep 2. in - let* () = - Store.set_exn t - ~info:(info "$ vim /etc/resolv.conf") - [ "etc"; "resolv.conf" ] "domain mydomain.com\nnameserver 12.221.130.23" - in - let* () = Lwt_unix.sleep 2. in + let t = Store.of_branch repo "prod" in + Eio_unix.sleep 2.; + Store.set_exn t + ~info:(info "$ vim /etc/resolv.conf") + [ "etc"; "resolv.conf" ] "domain mydomain.com\nnameserver 12.221.130.23"; + Eio_unix.sleep 2.; Store.set_exn t ~info:(info "$ gcc -c /tmp/sh.c -o /bin/sh") [ "bin"; "sh" ] "�����XpNx ������� H__PAGEZERO(__TEXT__text__TEXT [...]" let revert repo = - let* prod = Store.of_branch repo "prod" in - let* dev = Store.of_branch repo "dev" in - let* h1 = Store.Head.get prod in - let* h2 = Store.Head.get dev in + let prod = Store.of_branch repo "prod" in + let dev = Store.of_branch repo "dev" in + let h1 = Store.Head.get prod in + let h2 = Store.Head.get dev in if h1 <> h2 then ( Printf.printf "WARNING: the filesystem is different in dev and prod, intrusion detected!\n\ Reverting the production system to the dev environment.\n\ %!"; - let* () = Lwt_unix.sleep 2. in + Eio_unix.sleep 2.; Store.Head.set prod h2) - else Lwt.return_unit -let () = +let main () = let cmd = Sys.argv.(0) in let help () = Printf.eprintf @@ -111,32 +105,32 @@ let () = else match Sys.argv.(1) with | "provision" -> - Lwt_main.run - (let* repo = Store.Repo.v config in - provision repo); + (let repo = Store.Repo.v config in + provision repo); Printf.printf "The VM is now provisioned. Run `%s configure` to simulate a sysadmin \n\ configuration.\n" cmd | "configure" -> - Lwt_main.run - (let* repo = Store.Repo.v config in - configure repo); + (let repo = Store.Repo.v config in + configure repo); Printf.printf "The VM is now configured. Run `%s attack` to simulate an attack by \ an \n\ intruder.\n" cmd | "attack" -> - Lwt_main.run - (let* repo = Store.Repo.v config in - attack repo); + (let repo = Store.Repo.v config in + attack repo); Printf.printf "The VM has been attacked. Run `%s revert` to revert the VM state to \ a safe one.\n" cmd | "revert" -> - Lwt_main.run - (let* repo = Store.Repo.v config in - revert repo) + let repo = Store.Repo.v config in + revert repo | _ -> help () + +let () = + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> main () diff --git a/examples/dune b/examples/dune index 1bc148dba0..3d0e18031e 100644 --- a/examples/dune +++ b/examples/dune @@ -22,8 +22,10 @@ irmin-watcher websocket-lwt-unix conduit-lwt-unix + eio_main lwt - lwt.unix) + lwt.unix + lwt_eio) (preprocess (pps ppx_irmin))) diff --git a/examples/fold.ml b/examples/fold.ml index 152c985445..aaa9f33f06 100644 --- a/examples/fold.ml +++ b/examples/fold.ml @@ -16,7 +16,6 @@ (* example of using tree fold *) -open Lwt.Syntax module Store = Irmin_mem.KV.Make (Irmin.Contents.String) module Tree = Store.Tree @@ -43,58 +42,52 @@ end = struct let format : ('a, Format.formatter, unit) format = "Visit [%s]" ^^ if newline then "\n" else "" in - Fmt.(pf stdout format (String.concat ";" path)) |> Lwt.return + Fmt.(pf stdout format (String.concat ";" path)) let pre = print_path true let post = print_path true let node = print_path true let contents path c acc = - let* () = print_path false path c acc in - Fmt.(pf stdout " = '%s'\n" c) |> Lwt.return + print_path false path c acc; + Fmt.(pf stdout " = '%s'\n" c) let tree path t acc = - let* () = print_path false path t acc in - let* k = Tree.kind t [] in - match k with - | Some k' -> - (match k' with + print_path false path t acc; + match Tree.kind t [] with + | Some k' -> ( + match k' with | `Node -> Fmt.(string stdout ", with `Node kind\n") | `Contents -> Fmt.(string stdout ", with `Contents kind\n")) - |> Lwt.return | None -> failwith "no kind" end -let main = +let main () = let ps name = Fmt.(pf stdout "\n%s\n" name) in ps "Demo of how tree folders visit nodes."; - let* repo = Store.Repo.v config in - let* main_b = Store.main repo in - let* () = Store.set_exn ~info:(info "add c1") main_b [ "c1" ] "c1" in - let* () = Store.set_exn ~info:(info "add c2") main_b [ "c2" ] "c2" in - let* () = - Store.set_exn ~info:(info "add n1/c1") main_b [ "n1"; "c1" ] "n1/c1" - in - let* () = - Store.set_exn ~info:(info "add n1/n1/c1") main_b [ "n1"; "n1"; "c1" ] - "n1/n1/c1" - in - let* () = - Store.set_exn ~info:(info "add n2/c1") main_b [ "n2"; "c1" ] "n2/c1" - in - let* t = Store.tree main_b in + let repo = Store.Repo.v config in + let main_b = Store.main repo in + Store.set_exn ~info:(info "add c1") main_b [ "c1" ] "c1"; + Store.set_exn ~info:(info "add c2") main_b [ "c2" ] "c2"; + + Store.set_exn ~info:(info "add n1/c1") main_b [ "n1"; "c1" ] "n1/c1"; + Store.set_exn ~info:(info "add n1/n1/c1") main_b [ "n1"; "n1"; "c1" ] + "n1/n1/c1"; + Store.set_exn ~info:(info "add n2/c1") main_b [ "n2"; "c1" ] "n2/c1"; + let t = Store.tree main_b in (* let order = `Random (Random.State.make_self_init ()) in *) let order = `Sorted in ps "pre folder: preorder traversal of `Node kinds"; - let* () = Tree.fold ~order ~pre:Folder.pre t () in + Tree.fold ~order ~pre:Folder.pre t (); ps "post folder: postorder traversal of `Node kinds"; - let* () = Tree.fold ~order ~post:Folder.post t () in + Tree.fold ~order ~post:Folder.post t (); ps "node folder: visit all `Node kinds"; - let* () = Tree.fold ~order ~node:Folder.node t () in + Tree.fold ~order ~node:Folder.node t (); ps "contents folder: visit all `Contents kinds"; - let* () = Tree.fold ~order ~contents:Folder.contents t () in + Tree.fold ~order ~contents:Folder.contents t (); ps "tree folder: visit both `Node and `Contents kinds"; - let* () = Tree.fold ~order ~tree:Folder.tree t () in - Lwt.return_unit + Tree.fold ~order ~tree:Folder.tree t () -let () = Lwt_main.run main +let () = + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> main () diff --git a/examples/irmin_git_store.ml b/examples/irmin_git_store.ml index 9650429534..281ae15054 100644 --- a/examples/irmin_git_store.ml +++ b/examples/irmin_git_store.ml @@ -16,8 +16,6 @@ (* Simple example of reading and writing in a Git repository *) -open Lwt.Syntax - let info = Irmin_git_unix.info module Store = Irmin_git_unix.FS.KV (Irmin.Contents.String) @@ -35,31 +33,35 @@ let read_exn t k = let main () = Config.init (); let config = Irmin_git.config ~bare:true Config.root in - let* repo = Store.Repo.v config in - let* t = Store.main repo in - let* () = update t [ "root"; "misc"; "1.txt" ] "Hello world!" in - let* () = update t [ "root"; "misc"; "2.txt" ] "Hi!" in - let* () = update t [ "root"; "misc"; "3.txt" ] "How are you ?" in - let* _ = read_exn t [ "root"; "misc"; "2.txt" ] in - let* x = Store.clone ~src:t ~dst:"test" in + let repo = Store.Repo.v config in + let t = Store.main repo in + update t [ "root"; "misc"; "1.txt" ] "Hello world!"; + update t [ "root"; "misc"; "2.txt" ] "Hi!"; + update t [ "root"; "misc"; "3.txt" ] "How are you ?"; + let _ = read_exn t [ "root"; "misc"; "2.txt" ] in + let x = Store.clone ~src:t ~dst:"test" in print_endline "cloning ..."; - let* () = update t [ "root"; "misc"; "3.txt" ] "Hohoho" in - let* () = update x [ "root"; "misc"; "2.txt" ] "Cool!" in - let* r = Store.merge_into ~info:(info "t: Merge with 'x'") x ~into:t in + update t [ "root"; "misc"; "3.txt" ] "Hohoho"; + update x [ "root"; "misc"; "2.txt" ] "Cool!"; + let r = Store.merge_into ~info:(info "t: Merge with 'x'") x ~into:t in match r with | Error _ -> failwith "conflict!" | Ok () -> print_endline "merging ..."; - let* _ = read_exn t [ "root"; "misc"; "2.txt" ] in - let+ _ = read_exn t [ "root"; "misc"; "3.txt" ] in + let _ = read_exn t [ "root"; "misc"; "2.txt" ] in + let _ = read_exn t [ "root"; "misc"; "3.txt" ] in () -let () = +let main () = Printf.printf "This example creates a Git repository in %s and use it to read \n\ and write data:\n" Config.root; let _ = Sys.command (Printf.sprintf "rm -rf %s" Config.root) in - Lwt_main.run (main ()); + main (); Printf.printf "You can now run `cd %s && tig` to inspect the store.\n" Config.root + +let () = + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> main () diff --git a/examples/process.ml b/examples/process.ml index 04ce82b235..664ce841c0 100644 --- a/examples/process.ml +++ b/examples/process.ml @@ -16,8 +16,6 @@ (* Simple UI example: connect to http://localhost:8080/dump *) -open Lwt.Syntax - let fin () = let _ = Fmt.kstr Sys.command "cd %s && git reset HEAD --hard" Config.root in Lwt.return_unit @@ -114,13 +112,13 @@ let main = branch images.(0) let init () = Config.init (); - let* repo = Store.Repo.v config in - let* t = Store.of_branch repo main in - let* () = Store.set_exn t ~info:(info images.(0) "init") [ "0" ] "0" in - Lwt_list.iter_s + let repo = Store.Repo.v config in + let t = Store.of_branch repo main in + Store.set_exn t ~info:(info images.(0) "init") [ "0" ] "0"; + List.iter (fun i -> - let* _ = Store.clone ~src:t ~dst:(branch i) in - Lwt.return_unit) + let _ = Store.clone ~src:t ~dst:(branch i) in + ()) (Array.to_list images) let random_array a = a.(Random.int (Array.length a)) @@ -135,45 +133,41 @@ let rec process image = with _ -> ([ "log"; id; "0" ], fun () -> id ^ string_of_int (Random.int 10)) in - let* repo = Store.Repo.v config in - let* t = Store.of_branch repo id in - let* () = Store.set_exn t ~info:(info image actions.message) key (value ()) in - let* () = + let repo = Store.Repo.v config in + let t = Store.of_branch repo id in + Store.set_exn t ~info:(info image actions.message) key (value ()); + let () = if Random.int 3 = 0 then let branch = branch (random_array images) in if branch <> id then ( Printf.printf "Merging ...%!"; - let* r = + let r = Store.merge_with_branch t ~info:(info image @@ Fmt.str "Merging with %s" branch) branch in match r with - | Ok () -> - Printf.printf "ok!\n%!"; - Lwt.return_unit - | Error _ -> Lwt.fail_with "conflict!") - else Lwt.return_unit - else Lwt.return_unit + | Ok () -> Printf.printf "ok!\n%!" + | Error _ -> failwith "conflict!") in - let* () = Lwt_unix.sleep (max 0.1 (Random.float 0.3)) in + Eio_unix.sleep (max 0.1 (Random.float 0.3)); process image -let rec protect fn x = - Lwt.catch - (fun () -> fn x) - (fun e -> - Printf.eprintf "error: %s" (Printexc.to_string e); - protect fn x) +let rec protect fn x () = + try fn x + with e -> + Printf.eprintf "error: %s" (Printexc.to_string e); + protect fn x () let rec watchdog () = Printf.printf "I'm alive!\n%!"; - let* () = Lwt_unix.sleep 1. in + Eio_unix.sleep 1.; watchdog () +let main () = + init (); + Eio.Fiber.any (watchdog :: List.map (protect process) (Array.to_list images)) + let () = - let aux () = - let* () = init () in - Lwt.choose (watchdog () :: List.map (protect process) (Array.to_list images)) - in - Lwt_main.run (aux ()) + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> main () diff --git a/examples/push.ml b/examples/push.ml index 68c9252de6..04ae1c12ba 100644 --- a/examples/push.ml +++ b/examples/push.ml @@ -16,8 +16,6 @@ (* Simple example of Git push *) -open Lwt.Syntax - let info = Irmin_git_unix.info let url, user, token = @@ -34,21 +32,23 @@ let headers = let test () = Config.init (); let config = Irmin_git.config Config.root in - let* repo = Store.Repo.v config in - let* t = Store.main repo in - let* remote = Store.remote ~headers url in - let* _ = Sync.pull_exn t remote `Set in - let* readme = Store.get t [ "README.md" ] in - let* tree = Store.get_tree t [] in - let* tree = Store.Tree.add tree [ "BAR.md" ] "Hoho!" in - let* tree = Store.Tree.add tree [ "FOO.md" ] "Hihi!" in - let* () = Store.set_tree_exn t ~info:(info "merge") [] tree in + let repo = Store.Repo.v config in + let t = Store.main repo in + let remote = Store.remote ~headers url () in + let _ = Sync.pull_exn t remote `Set in + let readme = Store.get t [ "README.md" ] in + let tree = Store.get_tree t [] in + let tree = Store.Tree.add tree [ "BAR.md" ] "Hoho!" in + let tree = Store.Tree.add tree [ "FOO.md" ] "Hihi!" in + Store.set_tree_exn t ~info:(info "merge") [] tree; Printf.printf "%s\n%!" readme; - let* bar = Store.get t [ "BAR.md" ] in + let bar = Store.get t [ "BAR.md" ] in Printf.printf "%s\n%!" bar; - let* foo = Store.get t [ "FOO.md" ] in + let foo = Store.get t [ "FOO.md" ] in Printf.printf "%s\n%!" foo; - let+ _ = Sync.push_exn t remote in + let _ = Sync.push_exn t remote in () -let () = Lwt_main.run (test ()) +let () = + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> test () diff --git a/examples/readme.ml b/examples/readme.ml index e8c0f33a21..5377b2a5da 100644 --- a/examples/readme.ml +++ b/examples/readme.ml @@ -1,5 +1,3 @@ -open Lwt.Syntax - (* Irmin store with string contents *) module Store = Irmin_git_unix.FS.KV (Irmin.Contents.String) @@ -12,22 +10,21 @@ let author = "Example " (* Commit information *) let info fmt = Irmin_git_unix.info ~author fmt -let main = +let main () = (* Open the repo *) - let* repo = Store.Repo.v config in + let repo = Store.Repo.v config in (* Load the main branch *) - let* t = Store.main repo in + let t = Store.main repo in (* Set key "foo/bar" to "testing 123" *) - let* () = - Store.set_exn t ~info:(info "Updating foo/bar") [ "foo"; "bar" ] - "testing 123" - in + Store.set_exn t ~info:(info "Updating foo/bar") [ "foo"; "bar" ] "testing 123"; (* Get key "foo/bar" and print it to stdout *) - let+ x = Store.get t [ "foo"; "bar" ] in + let x = Store.get t [ "foo"; "bar" ] in Printf.printf "foo/bar => '%s'\n" x (* Run the program *) -let () = Lwt_main.run main +let () = + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> main () diff --git a/examples/sync.ml b/examples/sync.ml index 4f206b02cc..e2336e054c 100644 --- a/examples/sync.ml +++ b/examples/sync.ml @@ -14,8 +14,6 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Lwt.Syntax - let info = Irmin_git_unix.info let path = @@ -28,15 +26,17 @@ module Sync = Irmin.Sync.Make (Store) let test () = Config.init (); let config = Irmin_git.config Config.root in - let* repo = Store.Repo.v config in - let* t = Store.of_branch repo "master" in - let* upstream = Store.remote path in - let* _ = Sync.pull_exn t upstream `Set in - let* readme = Store.get t [ "README.md" ] in - let* tree = Store.get_tree t [] in - let* tree = Store.Tree.add tree [ "BAR.md" ] "Hoho!" in - let* tree = Store.Tree.add tree [ "FOO.md" ] "Hihi!" in - let+ () = Store.set_tree_exn t ~info:(info "merge") [] tree in + let repo = Store.Repo.v config in + let t = Store.of_branch repo "master" in + let upstream = Store.remote path () in + let _ = Sync.pull_exn t upstream `Set in + let readme = Store.get t [ "README.md" ] in + let tree = Store.get_tree t [] in + let tree = Store.Tree.add tree [ "BAR.md" ] "Hoho!" in + let tree = Store.Tree.add tree [ "FOO.md" ] "Hihi!" in + Store.set_tree_exn t ~info:(info "merge") [] tree; Printf.printf "%s\n%!" readme -let () = Lwt_main.run (test ()) +let () = + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> test () diff --git a/examples/trees.ml b/examples/trees.ml index 07a1a2bad5..c0f68fc005 100644 --- a/examples/trees.ml +++ b/examples/trees.ml @@ -16,7 +16,6 @@ (* example of using the tree API *) -open Lwt.Syntax module Store = Irmin_git_unix.FS.KV (Irmin.Contents.String) module Tree = Store.Tree @@ -27,12 +26,12 @@ type t2 = { x : string; y : t1 } type t = t2 list let tree_of_t t = - let+ tree, _ = - Lwt_list.fold_left_s + let tree, _ = + List.fold_left (fun (v, i) t2 -> let si = string_of_int i in - let* v = Tree.add v [ si; "x" ] t2.x in - let+ v = Tree.add v [ si; "y" ] (string_of_int t2.y) in + let v = Tree.add v [ si; "x" ] t2.x in + let v = Tree.add v [ si; "y" ] (string_of_int t2.y) in (v, i + 1)) (Tree.empty (), 0) t @@ -42,14 +41,14 @@ let tree_of_t t = let t_of_tree v = let aux acc i = let i = string_of_int i in - let* x = Tree.get v [ i; "x" ] in - let+ y = Tree.get v [ i; "y" ] in + let x = Tree.get v [ i; "x" ] in + let y = Tree.get v [ i; "y" ] in { x; y = int_of_string y } :: acc in - let* t2s = Tree.list v [] in + let t2s = Tree.list v [] in let t2s = List.map (fun (i, _) -> int_of_string i) t2s in let t2s = List.rev (List.sort compare t2s) in - Lwt_list.fold_left_s aux [] t2s + List.fold_left aux [] t2s let main () = Config.init (); @@ -57,15 +56,17 @@ let main () = let t = [ { x = "foo"; y = 3 }; { x = "bar"; y = 5 }; { x = "too"; y = 10 } ] in - let* v = tree_of_t t in - let* repo = Store.Repo.v config in - let* t = Store.main repo in - let* () = Store.set_tree_exn t ~info:(info "update a/b") [ "a"; "b" ] v in - let* v = Store.get_tree t [ "a"; "b" ] in - let* tt = t_of_tree v in - let* () = Store.set_tree_exn t ~info:(info "update a/c") [ "a"; "c" ] v in + let v = tree_of_t t in + let repo = Store.Repo.v config in + let t = Store.main repo in + Store.set_tree_exn t ~info:(info "update a/b") [ "a"; "b" ] v; + let v = Store.get_tree t [ "a"; "b" ] in + let tt = t_of_tree v in + Store.set_tree_exn t ~info:(info "update a/c") [ "a"; "c" ] v; let tt = tt @ [ { x = "ggg"; y = 4 } ] in - let* vv = tree_of_t tt in + let vv = tree_of_t tt in Store.set_tree_exn t ~info:(info "merge tree into a/b") [ "a"; "b" ] vv -let () = Lwt_main.run (main ()) +let () = + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> main () From cee443f905ca4833f816818932eeafe655a1ddb5 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Mon, 5 Jun 2023 13:12:21 +0200 Subject: [PATCH 24/99] Fix for libirmin --- README.md | 19 +++++------ examples/merkle_proofs.md | 34 +++++++++++--------- src/irmin-cli/cli.ml | 12 +++---- src/irmin-cli/dune | 4 +-- src/libirmin/commit.ml | 23 ++++++------- src/libirmin/dune | 2 +- src/libirmin/lib/dune | 9 ++---- src/libirmin/repo.ml | 8 ++--- src/libirmin/store.ml | 68 ++++++++++++++++++++++----------------- src/libirmin/tree.ml | 22 ++++++------- src/libirmin/util.ml | 11 ++----- 11 files changed, 105 insertions(+), 107 deletions(-) diff --git a/README.md b/README.md index 5025937aa1..62d72d7dee 100644 --- a/README.md +++ b/README.md @@ -178,8 +178,6 @@ Git-based, filesystem-backed store. ```ocaml -open Lwt.Syntax - (* Irmin store with string contents *) module Store = Irmin_git_unix.FS.KV (Irmin.Contents.String) @@ -192,25 +190,24 @@ let author = "Example " (* Commit information *) let info fmt = Irmin_git_unix.info ~author fmt -let main = +let main () = (* Open the repo *) - let* repo = Store.Repo.v config in + let repo = Store.Repo.v config in (* Load the main branch *) - let* t = Store.main repo in + let t = Store.main repo in (* Set key "foo/bar" to "testing 123" *) - let* () = - Store.set_exn t ~info:(info "Updating foo/bar") [ "foo"; "bar" ] - "testing 123" - in + Store.set_exn t ~info:(info "Updating foo/bar") [ "foo"; "bar" ] "testing 123"; (* Get key "foo/bar" and print it to stdout *) - let+ x = Store.get t [ "foo"; "bar" ] in + let x = Store.get t [ "foo"; "bar" ] in Printf.printf "foo/bar => '%s'\n" x (* Run the program *) -let () = Lwt_main.run main +let () = + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> main () ``` The example is contained in [examples/readme.ml](./examples/readme.ml) It can diff --git a/examples/merkle_proofs.md b/examples/merkle_proofs.md index 1fde16dff6..5c6c600050 100644 --- a/examples/merkle_proofs.md +++ b/examples/merkle_proofs.md @@ -12,8 +12,7 @@ More specifically, for Irmin, a Merkle proof is the subset of a tree stored in a # #require "irmin";; # #require "irmin-git.unix";; # #require "ppx_irmin";; -# open Lwt.Infix - open Lwt.Syntax;; +# #require "eio_main";; ``` First, create an irmin-unix store module which uses `int` as contents. @@ -26,13 +25,17 @@ module Contents = struct end module Store = Irmin_git_unix.FS.KV (Contents) + +let eio_run fn = + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:env#clock fn ``` Open a repo. ```ocaml # let config = Irmin_git.config ~bare:true "./tmp-irmin/test" - let repo = Lwt_main.run (Store.Repo.v config);; + let repo = eio_run @@ fun _ -> Store.Repo.v config;; val config : Irmin.config = val repo : Store.repo = ``` @@ -42,13 +45,13 @@ Create a tree which contains the accounts and their balance for 3 customers: Ben Instead of using `[ "eve" ]` as a path (which whould have been valid too), this example splits the names char by char. This is better in order to highlight how proofs work. ```ocaml -# let tree = Lwt_main.run ( +# let tree = eio_run @@ fun _ -> let tree = Store.Tree.empty () in - let* tree = Store.Tree.add tree [ "b"; "e"; "n" ] 10 in - let* tree = Store.Tree.add tree [ "b"; "o"; "b" ] 20 in - let+ tree = Store.Tree.add tree [ "e"; "v"; "e" ] 30 in + let tree = Store.Tree.add tree [ "b"; "e"; "n" ] 10 in + let tree = Store.Tree.add tree [ "b"; "o"; "b" ] 20 in + let tree = Store.Tree.add tree [ "e"; "v"; "e" ] 30 in tree - );; + ;; val tree : Store.tree = ``` @@ -57,9 +60,9 @@ In order to produce a Merkle proof, Irmin requires that the tree on which the pr `tree_key` is a value that encodes where `tree` has been persisted inside the store's backend. ```ocaml -# let tree_key = Lwt_main.run ( +# let tree_key = eio_run @@ fun _ -> (* [batch] exposes [repo] stores in read-write mode *) - let+ kinded_key = Store.Backend.Repo.batch repo + let kinded_key = Store.Backend.Repo.batch repo (fun rw_contents_store rw_node_store _rw_commit_store -> Store.save_tree repo rw_contents_store rw_node_store tree) in @@ -67,7 +70,7 @@ In order to produce a Merkle proof, Irmin requires that the tree on which the pr match kinded_key with | `Node key -> key | `Contents _ -> assert false - );; + ;; val tree_key : Store.node_key = ``` @@ -84,11 +87,11 @@ Let's produce an account statement for Eve. ```ocaml let visit_tree tree = (* [tree] is shallow. Let's only load the parts we are interested in *) - let+ (_ : int option) = Store.Tree.find tree [ "e"; "v"; "e" ] in + let (_ : int option) = Store.Tree.find tree [ "e"; "v"; "e" ] in (Store.Tree.empty (), `Success) -let proof, `Success = Lwt_main.run ( - Store.Tree.produce_proof repo (`Node tree_key) visit_tree) +let proof, `Success = eio_run @@ fun _ -> + Store.Tree.produce_proof repo (`Node tree_key) visit_tree let pp_merkle_proof = Irmin.Type.pp Store.Tree.Proof.tree_t ``` @@ -134,8 +137,7 @@ Here is the signature of `produce_proof`: val produce_proof : Store.repo -> Store.Tree.kinded_key -> - (Store.tree -> (Store.tree * 'a) Lwt.t) -> (Store.Tree.Proof.t * 'a) Lwt.t = - + (Store.tree -> Store.tree * 'a) -> Store.Tree.Proof.t * 'a = ``` `produce_proof repo key_before f` is `(proof = { state; hash_before; hash_after }, f_res)`. `f` is invoked once per call to `produce_proof` and `f tree_before` is `(tree_after, f_res)`. diff --git a/src/irmin-cli/cli.ml b/src/irmin-cli/cli.ml index 48b1d2b782..5ef2a3cbe7 100644 --- a/src/irmin-cli/cli.ml +++ b/src/irmin-cli/cli.ml @@ -22,7 +22,6 @@ module Graphql = Irmin_graphql_unix let deprecated_info = (Term.info [@alert "-deprecated"]) let deprecated_man_format = (Term.man_format [@alert "-deprecated"]) let deprecated_eval_choice = (Term.eval_choice [@alert "-deprecated"]) -let () = Irmin.Backend.Watch.set_listen_dir_hook Irmin_watcher.hook let info (type a) (module S : Irmin.Generic_key.S with type Schema.Info.t = a) ?(author = "irmin") fmt = @@ -110,12 +109,7 @@ let print_exc exc = open Lwt.Syntax -let run t = - Eio_main.run @@ fun env -> - Irmin_fs.run env#fs @@ fun () -> - Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> - try t () with err -> print_exc err - +let run t = try t () with err -> print_exc err let mk (fn : 'a) : 'a Term.t = Term.(const (fun () -> fn) $ setup_log) (* INIT *) @@ -997,4 +991,8 @@ let commands = ] let run ~default:x y = + Eio_main.run @@ fun env -> + Irmin_fs.run env#fs @@ fun () -> + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> + Irmin.Backend.Watch.set_listen_dir_hook Irmin_watcher.hook; match deprecated_eval_choice x y with `Error _ -> exit 1 | _ -> () diff --git a/src/irmin-cli/dune b/src/irmin-cli/dune index 269c2ada7f..8496c072ab 100644 --- a/src/irmin-cli/dune +++ b/src/irmin-cli/dune @@ -19,8 +19,8 @@ cohttp-lwt-unix unix yaml - lwt_eio - eio_main) + eio_main + lwt_eio) (preprocess (pps ppx_irmin.internal)) (instrumentation diff --git a/src/libirmin/commit.ml b/src/libirmin/commit.ml index aca0c58699..a5b5329069 100644 --- a/src/libirmin/commit.ml +++ b/src/libirmin/commit.ml @@ -52,7 +52,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct (fun (module Store : Irmin.Generic_key.S with type repo = repo) repo -> let hash = Root.get_hash (module Store) hash in - let c = run (Store.Commit.of_hash repo hash) in + let c = run (fun () -> Store.Commit.of_hash repo hash) in match c with | Some c -> Root.create_commit (module Store) c | None -> null commit)) @@ -65,7 +65,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct (fun (module Store : Irmin.Generic_key.S with type repo = repo) repo -> let hash = Root.get_commit_key (module Store) hash in - let c = run (Store.Commit.of_key repo hash) in + let c = run (fun () -> Store.Commit.of_key repo hash) in match c with | Some c -> Root.create_commit (module Store) c | None -> null commit)) @@ -88,11 +88,12 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct in let tree = Root.get_tree (module Store) tree in let info = Root.get_info (module Store) info in - let commit = run (Store.Commit.v repo ~parents ~info tree) in + let commit = + run (fun () -> Store.Commit.v repo ~parents ~info tree) + in Root.create_commit (module Store) commit)) let () = - let open Lwt.Infix in fn "commit_parents" (repo @-> commit @-> returning commit_array) (fun (type repo) repo commit -> @@ -102,13 +103,13 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct let commit = Root.get_commit (module Store) commit in let parents = Store.Commit.parents commit in let parents = - run - (Lwt_list.filter_map_s - (fun x -> - Store.Commit.of_key repo x >|= function - | None -> None - | Some x -> Some x) - parents) + run (fun () -> + List.filter_map + (fun x -> + match Store.Commit.of_key repo x with + | None -> None + | Some x -> Some x) + parents) in Root.create_commit_array (module Store) parents)) diff --git a/src/libirmin/dune b/src/libirmin/dune index 1672aa7e69..fdcc3d3560 100644 --- a/src/libirmin/dune +++ b/src/libirmin/dune @@ -1,5 +1,5 @@ (library (name libirmin_bindings) - (libraries irmin-cli irmin.unix ctypes.foreign) + (libraries irmin-cli irmin.unix ctypes.foreign eio_main lwt_eio) (instrumentation (backend bisect_ppx))) diff --git a/src/libirmin/lib/dune b/src/libirmin/lib/dune index dbfd80157a..a844945ed7 100644 --- a/src/libirmin/lib/dune +++ b/src/libirmin/lib/dune @@ -16,7 +16,9 @@ (modules libirmin irmin_bindings) (foreign_stubs (language c) - (names irmin))) + (names irmin)) + (flags + (-w -unused-var-strict -ccopt "-Wl,-znow"))) (install (package libirmin) @@ -24,8 +26,3 @@ (files (irmin.h as include/irmin.h) (libirmin.so as lib/libirmin.so))) - -(env - (dev - (flags - (:standard -w -unused-var-strict)))) diff --git a/src/libirmin/repo.ml b/src/libirmin/repo.ml index 55635baaff..c0b57b543a 100644 --- a/src/libirmin/repo.ml +++ b/src/libirmin/repo.ml @@ -24,7 +24,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct let (s, config) : config = Root.get_config config in let (module Store) = Irmin_cli.Resolver.Store.generic_keyed s in let remote = Irmin_cli.Resolver.Store.remote s in - let repo : Store.repo = run (Store.Repo.v config) in + let repo : Store.repo = run (fun () -> Store.Repo.v config) in Root.create_repo (module Store) { @@ -42,7 +42,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct with_repo' repo branch_array (fun (module Store : Irmin.Generic_key.S with type repo = repo) repo -> - let b = run (Store.Repo.branches repo) in + let b = run (fun () -> Store.Repo.branches repo) in Root.create_branch_array (module Store) b)) let () = @@ -94,7 +94,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct (fun (module Store : Irmin.Generic_key.S with type repo = repo) repo -> let a = Root.get_hash (module Store) a in - let c = run @@ Store.Contents.of_hash repo a in + let c = run @@ fun () -> Store.Contents.of_hash repo a in match c with | Some c -> Root.create_contents (module Store) c | None -> null contents)) @@ -109,7 +109,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct let a = Root.get_kinded_key (module Store) a in match a with | `Contents (a, _) -> ( - let c = run @@ Store.Contents.of_key repo a in + let c = run @@ fun () -> Store.Contents.of_key repo a in match c with | Some c -> Root.create_contents (module Store) c | None -> null contents) diff --git a/src/libirmin/store.ml b/src/libirmin/store.ml index 6b12c6b535..d892647ea4 100644 --- a/src/libirmin/store.ml +++ b/src/libirmin/store.ml @@ -31,7 +31,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct repo = r; store_mod = (module Store : Irmin.Generic_key.S with type t = Store.t); - store = run (Store.main repo); + store = run (fun () -> Store.main repo); })) let () = @@ -51,7 +51,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct repo = r; store_mod = (module Store : Irmin.Generic_key.S with type t = Store.t); - store = run (Store.of_branch repo branch); + store = run (fun () -> Store.of_branch repo branch); })) let () = @@ -68,7 +68,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct repo = r; store_mod = (module Store : Irmin.Generic_key.S with type t = Store.t); - store = run (Store.of_commit commit); + store = run (fun () -> Store.of_commit commit); })) let () = @@ -77,7 +77,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct (fun (type t) store -> with_store' store commit (fun (module Store : Irmin.Generic_key.S with type t = t) store -> - let c = run (Store.Head.find store) in + let c = run (fun () -> Store.Head.find store) in match c with | None -> null commit | Some x -> Root.create_commit (module Store) x)) @@ -89,7 +89,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct with_store store () (fun (module Store : Irmin.Generic_key.S with type t = t) store -> let commit : Store.commit = Root.get_commit (module Store) commit in - run (Store.Head.set store commit))) + run (fun () -> Store.Head.set store commit))) let () = fn "fast_forward" @@ -98,7 +98,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct with_store store false (fun (module Store : Irmin.Generic_key.S with type t = t) store -> let commit : Store.commit = Root.get_commit (module Store) commit in - let res = run (Store.Head.fast_forward store commit) in + let res = run (fun () -> Store.Head.fast_forward store commit) in match res with | Ok () -> true | Error e -> failwith (Irmin.Type.to_string Store.ff_error_t e))) @@ -114,7 +114,8 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct Irmin.Type.of_string Store.branch_t branch |> Result.get_ok in let res = - run (Store.merge_with_branch store branch ~info:(fun () -> info)) + run (fun () -> + Store.merge_with_branch store branch ~info:(fun () -> info)) in match res with | Ok () -> true @@ -131,7 +132,8 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct let info = Root.get_info (module Store) info in let commit = Root.get_commit (module Store) commit in let res = - run (Store.merge_with_commit store commit ~info:(fun () -> info)) + run (fun () -> + Store.merge_with_commit store commit ~info:(fun () -> info)) in match res with | Ok () -> true @@ -148,9 +150,8 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct let store1 = Root.get_store store1 in let info = Root.get_info (module Store) info in let res = - run - (Store.merge_into ~into:store store1.store ~info:(fun () -> - info)) + run @@ fun () -> + Store.merge_into ~into:store store1.store ~info:(fun () -> info) in match res with | Ok () -> true @@ -169,7 +170,9 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct let value : Store.contents = Root.get_contents (module Store) value in - let x = run (Store.set store path value ~info:(fun () -> info)) in + let x = + run @@ fun () -> Store.set store path value ~info:(fun () -> info) + in match x with | Ok () -> true | Error e -> @@ -193,8 +196,8 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct else Some (Root.get_contents (module Store) set) in let x = - run - (Store.test_and_set store path ~test ~set ~info:(fun () -> info)) + run @@ fun () -> + Store.test_and_set store path ~test ~set ~info:(fun () -> info) in match x with | Ok () -> true @@ -219,9 +222,9 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct else Some (Root.get_tree (module Store) set) in let x = - run - (Store.test_and_set_tree store path ~test ~set ~info:(fun () -> - info)) + run @@ fun () -> + Store.test_and_set_tree store path ~test ~set ~info:(fun () -> + info) in match x with | Ok () -> true @@ -239,7 +242,8 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct let path : Store.path = Root.get_path (module Store) path in let tree' : Store.tree = Root.get_tree (module Store) tree in let x = - run (Store.set_tree store path tree' ~info:(fun () -> info)) + run @@ fun () -> + Store.set_tree store path tree' ~info:(fun () -> info) in match x with | Ok () -> true @@ -254,7 +258,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct with_store' store contents (fun (module Store : Irmin.Generic_key.S with type t = t) store -> let path : Store.path = Root.get_path (module Store) path in - let x = run (Store.find store path) in + let x = run (fun () -> Store.find store path) in match x with | Some x -> Root.create_contents (module Store) x | None -> null contents)) @@ -266,7 +270,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct with_store' store metadata (fun (module Store : Irmin.Generic_key.S with type t = t) store -> let path : Store.path = Root.get_path (module Store) path in - let x = run (Store.find_all store path) in + let x = run (fun () -> Store.find_all store path) in match x with | Some (_, m) -> Root.create_metadata (module Store) m | None -> null metadata)) @@ -278,7 +282,9 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct with_store' store tree (fun (module Store : Irmin.Generic_key.S with type t = t) store -> let path : Store.path = Root.get_path (module Store) path in - let x : Store.tree option = run (Store.find_tree store path) in + let x : Store.tree option = + run (fun () -> Store.find_tree store path) + in match x with | Some x -> Root.create_tree (module Store) x | None -> null tree)) @@ -292,7 +298,9 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct let module Info = Irmin_unix.Info (Store.Info) in let info = Root.get_info (module Store) info in let path : Store.path = Root.get_path (module Store) path in - match run (Store.remove store path ~info:(fun () -> info)) with + match + run (fun () -> Store.remove store path ~info:(fun () -> info)) + with | Ok () -> true | Error e -> let s = Irmin.Type.to_string Store.write_error_t e in @@ -305,7 +313,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct with_store store false (fun (module Store : Irmin.Generic_key.S with type t = t) store -> let path : Store.path = Root.get_path (module Store) path in - run (Store.mem store path))) + run (fun () -> Store.mem store path))) let () = fn "mem_tree" @@ -314,7 +322,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct with_store store false (fun (module Store : Irmin.Generic_key.S with type t = t) store -> let path : Store.path = Root.get_path (module Store) path in - run (Store.mem_tree store path))) + run (fun () -> Store.mem_tree store path))) let () = fn "list" @@ -323,7 +331,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct with_store' store path_array (fun (module Store : Irmin.Generic_key.S with type t = t) store -> let path : Store.path = Root.get_path (module Store) path in - let items = run (Store.list store path) in + let items = run (fun () -> Store.list store path) in let items = List.map (fun (k, _v) -> Store.Path.v [ k ]) items in Root.create_path_array (module Store) items)) @@ -368,7 +376,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct match remote_fn with | None -> failwith "sync is not implemented for the selected backend" - | Some f -> Root.create_remote (run (f url)))) + | Some f -> Root.create_remote (run (fun () -> f url ())))) let () = fn "remote_with_auth" @@ -390,7 +398,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct (`Basic (user, token)) | _ -> Cohttp.Header.add_authorization headers (`Other user) in - Root.create_remote (run (f ~headers url)))) + Root.create_remote (run (fun () -> f ~headers url ())))) let () = fn "fetch" @@ -404,7 +412,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct else Root.get_remote remote in let depth = if depth <= 0 then None else Some depth in - match run (Sync.fetch_exn ?depth store remote) with + match run (fun () -> Sync.fetch_exn ?depth store remote) with | `Empty -> null commit | `Head head -> Root.create_commit (module Store) head)) @@ -424,7 +432,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct else `Merge (fun () -> Root.get_info (module Store) info) in let depth = if depth <= 0 then None else Some depth in - match run (Sync.pull_exn ?depth store remote x) with + match run (fun () -> Sync.pull_exn ?depth store remote x) with | `Empty -> null commit | `Head head -> Root.create_commit (module Store) head)) @@ -440,7 +448,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct else Root.get_remote remote in let depth = if depth <= 0 then None else Some depth in - match run (Sync.push_exn ?depth store remote) with + match run (fun () -> Sync.push_exn ?depth store remote) with | `Empty -> null commit | `Head head -> Root.create_commit (module Store) head)) diff --git a/src/libirmin/tree.ml b/src/libirmin/tree.ml index caaf97f328..447a117446 100644 --- a/src/libirmin/tree.ml +++ b/src/libirmin/tree.ml @@ -67,7 +67,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct (fun (module Store : Irmin.Generic_key.S with type repo = repo) repo -> let k = Root.get_hash (module Store) k in - let t = run (Store.Tree.of_hash repo (`Node k)) in + let t = run (fun () -> Store.Tree.of_hash repo (`Node k)) in match t with | Some t -> Root.create_tree (module Store) t | None -> null tree)) @@ -92,7 +92,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct (fun (module Store : Irmin.Generic_key.S with type repo = repo) repo -> let k = Root.get_kinded_key (module Store) k in - let t = run (Store.Tree.of_key repo k) in + let t = run (fun () -> Store.Tree.of_key repo k) in match t with | Some t -> Root.create_tree (module Store) t | None -> null tree)) @@ -105,7 +105,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> let tree : Store.tree = Root.get_tree (module Store) tree in let path : Store.path = Root.get_path (module Store) path in - run (Store.Tree.mem tree path))) + run (fun () -> Store.Tree.mem tree path))) let () = fn "tree_mem_tree" @@ -115,7 +115,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> let tree : Store.tree = Root.get_tree (module Store) tree in let path : Store.path = Root.get_path (module Store) path in - run (Store.Tree.mem_tree tree path))) + run (fun () -> Store.Tree.mem_tree tree path))) let () = fn "tree_find" @@ -125,7 +125,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> let tree : Store.tree = Root.get_tree (module Store) tree in let path : Store.path = Root.get_path (module Store) path in - match run (Store.Tree.find tree path) with + match run (fun () -> Store.Tree.find tree path) with | None -> null contents | Some x -> Root.create_contents (module Store) x)) @@ -137,7 +137,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> let tree : Store.tree = Root.get_tree (module Store) tree in let path : Store.path = Root.get_path (module Store) path in - match run (Store.Tree.find_all tree path) with + match run (fun () -> Store.Tree.find_all tree path) with | None -> null metadata | Some (_, m) -> Root.create_metadata (module Store) m)) @@ -149,7 +149,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> let t : Store.tree = Root.get_tree (module Store) t in let path : Store.path = Root.get_path (module Store) path in - match run (Store.Tree.find_tree t path) with + match run (fun () -> Store.Tree.find_tree t path) with | None -> null tree | Some x -> Root.create_tree (module Store) x)) @@ -168,7 +168,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct if is_null metadata then None else Some (Root.get_metadata (module Store) metadata) in - let t = run (Store.Tree.add tree' path value ?metadata) in + let t = run (fun () -> Store.Tree.add tree' path value ?metadata) in Root.set_tree (module Store) tree t; true)) @@ -181,7 +181,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct let tree' : Store.tree = Root.get_tree (module Store) tree in let path : Store.path = Root.get_path (module Store) path in let value : Store.tree = Root.get_tree (module Store) tr in - let t = run (Store.Tree.add_tree tree' path value) in + let t = run (fun () -> Store.Tree.add_tree tree' path value) in Root.set_tree (module Store) tree t; true)) @@ -193,7 +193,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> let tree' : Store.tree = Root.get_tree (module Store) tree in let path : Store.path = Root.get_path (module Store) path in - let t = run (Store.Tree.remove tree' path) in + let t = run (fun () -> Store.Tree.remove tree' path) in Root.set_tree (module Store) tree t; true)) @@ -215,7 +215,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> let tree = Root.get_tree (module Store) tree in let path : Store.path = Root.get_path (module Store) path in - let items = run (Store.Tree.list tree path) in + let items = run (fun () -> Store.Tree.list tree path) in let items = List.map (fun (k, _v) -> Store.Path.v [ k ]) items in Root.create_path_array (module Store) items)) diff --git a/src/libirmin/util.ml b/src/libirmin/util.ml index 5213693131..3b0ad52b31 100644 --- a/src/libirmin/util.ml +++ b/src/libirmin/util.ml @@ -43,14 +43,9 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct let fn name t f = I.internal ~runtime_lock:false ("irmin_" ^ name) t f - (* Minimal executor for lwt promises *) - let rec run x = - Lwt.wakeup_paused (); - match Lwt.poll x with - | Some x -> x - | None -> - let () = Lwt_engine.iter true in - run x + let run fn = + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> fn () module Root = struct let to_voidp t x = Ctypes.coerce t (ptr void) x From e6da5e20c8cdc80993d7bb4f25ddff1e040a099d Mon Sep 17 00:00:00 2001 From: ArthurW Date: Thu, 29 Jun 2023 16:32:27 +0200 Subject: [PATCH 25/99] Fix opam dependencies to lwt_eio --- irmin-git.opam | 1 + irmin-graphql.opam | 1 + irmin-http.opam | 40 ++++++++++++++++++++++++++++++++++++++++ irmin-mirage.opam | 1 + 4 files changed, 43 insertions(+) create mode 100644 irmin-http.opam diff --git a/irmin-git.opam b/irmin-git.opam index 1f1ad0569a..cb2df42529 100644 --- a/irmin-git.opam +++ b/irmin-git.opam @@ -29,6 +29,7 @@ depends: [ "fpath" "logs" "lwt" {>= "5.3.0"} + "lwt_eio" {>= "0.3.0"} "uri" "mimic" "irmin-test" {with-test & = version} diff --git a/irmin-graphql.opam b/irmin-graphql.opam index 7d6e9e1c48..ff2b2a9a0d 100644 --- a/irmin-graphql.opam +++ b/irmin-graphql.opam @@ -27,6 +27,7 @@ depends: [ "git-unix" {>= "3.7.0"} "fmt" "lwt" {>= "5.3.0"} + "lwt_eio" {>= "0.3.0"} "alcotest-lwt" {with-test & >= "1.1.0"} "yojson" {with-test} "alcotest" {with-test & >= "1.2.3"} diff --git a/irmin-http.opam b/irmin-http.opam new file mode 100644 index 0000000000..a78a194d0f --- /dev/null +++ b/irmin-http.opam @@ -0,0 +1,40 @@ +opam-version: "2.0" +maintainer: "thomas@gazagnaire.org" +authors: ["Thomas Gazagnaire" "Thomas Leonard"] +license: "ISC" +homepage: "https://github.com/mirage/irmin" +bug-reports: "https://github.com/mirage/irmin/issues" +dev-repo: "git+https://github.com/mirage/irmin.git" +doc: "https://mirage.github.io/irmin/" + +build: [ + ["dune" "subst"] {dev} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test & os != "macos"} +] + +depends: [ + "ocaml" {>= "4.02.3"} + "dune" {>= "2.9.0"} + "crunch" {>= "2.2.0"} + "webmachine" {>= "0.6.0"} + "irmin" {= version} + "ppx_irmin" {= version} + "cohttp-lwt" {>= "1.0.0"} + "cohttp-lwt-unix" {>= "1.0.0"} + "astring" + "cohttp" + "fmt" + "jsonm" + "logs" + "lwt" {>= "5.3.0"} + "lwt_eio" {>= "0.3.0"} + "uri" + "irmin-git" {with-test & = version} + "irmin-fs" {with-test & = version} + "irmin-test" {with-test & = version} + "git-unix" {with-test & >= "3.5.0"} + "digestif" {with-test & >= "0.9.0"} +] + +synopsis: "HTTP client and server for Irmin" diff --git a/irmin-mirage.opam b/irmin-mirage.opam index 710d97af26..11dba5029c 100644 --- a/irmin-mirage.opam +++ b/irmin-mirage.opam @@ -18,6 +18,7 @@ depends: [ "fmt" "ptime" "mirage-clock" {>= "3.0.0"} + "lwt_eio" {>= "0.3.0"} ] synopsis: "MirageOS-compatible Irmin stores" From b30c33a7e93c38828df18922a30bbbb5f897a025 Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Mon, 5 Jun 2023 14:55:03 +0200 Subject: [PATCH 26/99] Add multicore tests --- test/multirmin/dune | 4 ++++ test/multirmin/test.ml | 48 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 52 insertions(+) create mode 100644 test/multirmin/dune create mode 100644 test/multirmin/test.ml diff --git a/test/multirmin/dune b/test/multirmin/dune new file mode 100644 index 0000000000..ffb0751ab7 --- /dev/null +++ b/test/multirmin/dune @@ -0,0 +1,4 @@ +(executable + (name test) + (modules test) + (libraries irmin irmin-test eio_main test_pack)) diff --git a/test/multirmin/test.ml b/test/multirmin/test.ml new file mode 100644 index 0000000000..bce12544b5 --- /dev/null +++ b/test/multirmin/test.ml @@ -0,0 +1,48 @@ +open Common + +let root = Filename.concat "_build" "test-readonly" + +module S = struct + module Maker = Irmin_pack_unix.Maker (Conf) + include Maker.Make (Schema) +end + +let config ?(readonly = false) ?(fresh = true) root = + Irmin_pack.config ~readonly ?index_log_size ~fresh root + +let info () = S.Info.empty + +let do_the_do ro i = + let t = S.main ro in + let c = S.Head.get t in + match S.Commit.of_hash ro (S.Commit.hash c) with + | None -> failwith "no hash" + | Some commit -> + let tree = S.Commit.tree commit in + let x = S.Tree.find tree [ "a" ] in + if x <> Some "x" then failwith "RO find"; + Format.printf "Done: i:%d d:%d@." i (Domain.self () :> int) + +let repeatedly_do fn arg () = + for _ = 0 to 100 do + Sys.opaque_identity (fn arg) + done + +let open_ro_after_rw_closed env = + rm_dir root; + let rw = S.Repo.v (config ~readonly:false ~fresh:true root) in + let t = S.main rw in + let tree = S.Tree.singleton [ "a" ] "x" in + S.set_tree_exn ~parents:[] ~info t [] tree; + S.Repo.close rw; + let ro = S.Repo.v (config ~readonly:true ~fresh:false root) in + let l = + List.init 7 (fun i () -> + Eio.Domain_manager.run env (repeatedly_do (do_the_do ro) i)) + in + Eio.Fiber.all l; + S.Repo.close ro + +let () = + Logs.set_level None; + Eio_main.run @@ fun env -> open_ro_after_rw_closed env#domain_mgr From 426b76aa9f853ce317d34d1357ff37c6336aa980 Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Tue, 30 May 2023 17:29:23 +0200 Subject: [PATCH 27/99] Add lock on branch --- src/irmin/store.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/irmin/store.ml b/src/irmin/store.ml index 75cfcf0f3f..f3507c286d 100644 --- a/src/irmin/store.ml +++ b/src/irmin/store.ml @@ -543,6 +543,7 @@ module Make (B : Backend.S) = struct | `Head key -> Some key | `Empty -> None | `Branch name -> ( + Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> match Branch_store.find (branch_store t) name with | None -> None | Some k -> Commit.of_key t.repo k) From 151c25c09fbdb1e6c7dd8d46c6f70237f003b9d5 Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Mon, 5 Jun 2023 14:59:21 +0200 Subject: [PATCH 28/99] Fix LRU hashtable with a mutex --- src/irmin/lru.ml | 44 +++++++++++++++++++++++++++++++++++++++----- 1 file changed, 39 insertions(+), 5 deletions(-) diff --git a/src/irmin/lru.ml b/src/irmin/lru.ml index 79fb7f7edc..2ff3cc74aa 100644 --- a/src/irmin/lru.ml +++ b/src/irmin/lru.ml @@ -16,7 +16,7 @@ (* Extracted from https://github.com/pqwy/lru *) -module Make (H : Hashtbl.HashedType) = struct +module MakeUnsafe (H : Hashtbl.HashedType) = struct module HT = Hashtbl.Make (H) module Q = struct @@ -134,10 +134,12 @@ module Make (H : Hashtbl.HashedType) = struct append t.q n) with Not_found -> () - let find t k = - let v = HT.find t.ht k in - promote t k; - snd v.value + let find_opt t k = + match HT.find_opt t.ht k with + | Some v -> + promote t k; + Some (snd v.value) + | None -> None let mem t k = match HT.mem t.ht k with @@ -153,3 +155,35 @@ module Make (H : Hashtbl.HashedType) = struct HT.clear t.ht; Q.clear t.q end + +(** Safe but might be incredibly slow. *) +module Make (H : Hashtbl.HashedType) = struct + module Unsafe = MakeUnsafe (H) + + type 'a t = { lock : Eio.Mutex.t; data : 'a Unsafe.t } + + let create cap = + let lock = Eio.Mutex.create () in + let data = Unsafe.create cap in + { lock; data } + + let add { lock; data } k v = + Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.add data k v + + let find_opt { lock; data } k = + Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.find_opt data k + + let find t k = match find_opt t k with Some v -> v | None -> raise Not_found + + let mem { lock; data } k = + Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.mem data k + + let iter { lock; data } f = + Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.iter data f + + let clear { lock; data } = + Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.clear data + + let drop { lock; data } = + Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.drop data +end From 2204a24c8ab1f718d86e22a5306cdbf4eff0f8b6 Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Mon, 5 Jun 2023 15:00:04 +0200 Subject: [PATCH 29/99] Fixed data race in stat counting --- src/irmin-pack/unix/stats.ml | 68 +++++++++++++++++-------------- src/irmin-pack/unix/stats_intf.ml | 14 +++---- src/irmin/metrics.ml | 17 ++++---- 3 files changed, 54 insertions(+), 45 deletions(-) diff --git a/src/irmin-pack/unix/stats.ml b/src/irmin-pack/unix/stats.ml index a9fb086a9c..77b52d99d1 100644 --- a/src/irmin-pack/unix/stats.ml +++ b/src/irmin-pack/unix/stats.ml @@ -40,39 +40,45 @@ module Pack_store = struct t let clear m = - let v = Metrics.state m in - v.appended_hashes <- 0; - v.appended_offsets <- 0; - v.total <- 0; - v.from_staging <- 0; - v.from_lru <- 0; - v.from_pack_direct <- 0; - v.from_pack_indexed <- 0 + let v = + { + appended_hashes = 0; + appended_offsets = 0; + total = 0; + from_staging = 0; + from_lru = 0; + from_pack_direct = 0; + from_pack_indexed = 0; + } + in + Metrics.set_state m v let export m = Metrics.state m let update ~field finds = let f v = match field with - | Appended_hashes -> v.appended_hashes <- succ v.appended_hashes - | Appended_offsets -> v.appended_offsets <- succ v.appended_offsets + | Appended_hashes -> { v with appended_hashes = succ v.appended_hashes } + | Appended_offsets -> + { v with appended_offsets = succ v.appended_offsets } | Staging -> - v.total <- succ v.total; - v.from_staging <- succ v.from_staging - | Lru -> - v.total <- succ v.total; - v.from_lru <- succ v.from_lru + { v with total = succ v.total; from_staging = succ v.from_staging } + | Lru -> { v with total = succ v.total; from_lru = succ v.from_lru } | Pack_direct -> - v.total <- succ v.total; - v.from_pack_direct <- succ v.from_pack_direct + { + v with + total = succ v.total; + from_pack_direct = succ v.from_pack_direct; + } | Pack_indexed -> - v.total <- succ v.total; - v.from_pack_indexed <- succ v.from_pack_indexed - | Not_found -> - v.total <- succ v.total; - () + { + v with + total = succ v.total; + from_pack_indexed = succ v.from_pack_indexed; + } + | Not_found -> { v with total = succ v.total } in - let mut = Metrics.Mutate f in + let mut = Metrics.Replace f in Metrics.update finds mut let cache_misses @@ -187,15 +193,15 @@ module File_manager = struct let update ~field t = let f t = match field with - | Dict_flushes -> t.dict_flushes <- t.dict_flushes + 1 - | Suffix_flushes -> t.suffix_flushes <- t.suffix_flushes + 1 - | Index_flushes -> t.index_flushes <- t.index_flushes + 1 - | Auto_dict -> t.auto_dict <- t.auto_dict + 1 - | Auto_suffix -> t.auto_suffix <- t.auto_suffix + 1 - | Auto_index -> t.auto_index <- t.auto_index + 1 - | Flush -> t.flush <- t.flush + 1 + | Dict_flushes -> { t with dict_flushes = succ t.dict_flushes } + | Suffix_flushes -> { t with suffix_flushes = succ t.suffix_flushes } + | Index_flushes -> { t with index_flushes = succ t.index_flushes } + | Auto_dict -> { t with auto_dict = succ t.auto_dict } + | Auto_suffix -> { t with auto_suffix = succ t.auto_suffix } + | Auto_index -> { t with auto_index = succ t.auto_index } + | Flush -> { t with flush = succ t.flush } in - Metrics.update t (Metrics.Mutate f) + Metrics.update t (Metrics.Replace f) end module Latest_gc = struct diff --git a/src/irmin-pack/unix/stats_intf.ml b/src/irmin-pack/unix/stats_intf.ml index 9a0ce38c14..175bca42b5 100644 --- a/src/irmin-pack/unix/stats_intf.ml +++ b/src/irmin-pack/unix/stats_intf.ml @@ -31,13 +31,13 @@ module Pack_store = struct [@@deriving irmin] type t = { - mutable appended_hashes : int; - mutable appended_offsets : int; - mutable total : int; - mutable from_staging : int; - mutable from_lru : int; - mutable from_pack_direct : int; - mutable from_pack_indexed : int; + appended_hashes : int; + appended_offsets : int; + total : int; + from_staging : int; + from_lru : int; + from_pack_direct : int; + from_pack_indexed : int; } [@@deriving irmin] end diff --git a/src/irmin/metrics.ml b/src/irmin/metrics.ml index eb3422c4c1..3e0ab790ea 100644 --- a/src/irmin/metrics.ml +++ b/src/irmin/metrics.ml @@ -27,11 +27,11 @@ type 'a t = { name : string; origin : origin option; repr : 'a Repr.ty; - mutable state : 'a; + state : 'a Atomic.t; } -let state m = m.state -let set_state m v = m.state <- v +let state m = Atomic.get m.state +let set_state m v = Atomic.set m.state v type 'a update_mode = Mutate of ('a -> unit) | Replace of ('a -> 'a) @@ -39,8 +39,11 @@ let v : type a. ?origin:origin -> name:string -> initial_state:a -> a Repr.ty -> a t = fun ?origin ~name ~initial_state repr -> - { uid = uid (); origin; name; repr; state = initial_state } + { uid = uid (); origin; name; repr; state = Atomic.make initial_state } -let update : type a. a t -> a update_mode -> unit = - fun m kind -> - match kind with Mutate f -> f m.state | Replace f -> m.state <- f m.state +let rec update m kind = + let old = Atomic.get m.state in + match kind with + | Mutate f -> f old + | Replace f -> + if not @@ Atomic.compare_and_set m.state old (f old) then update m kind From 791695aa4a3f53753e252f16a9300dc57250df06 Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Mon, 5 Jun 2023 15:00:16 +0200 Subject: [PATCH 30/99] Fixed data race in tree counters --- src/irmin/tree.ml | 77 ++++++++++++++++++++++++----------------------- 1 file changed, 39 insertions(+), 38 deletions(-) diff --git a/src/irmin/tree.ml b/src/irmin/tree.ml index 8b3fa3278e..50ba1752df 100644 --- a/src/irmin/tree.ml +++ b/src/irmin/tree.ml @@ -80,9 +80,7 @@ module Make (P : Backend.S) = struct } [@@deriving irmin] - let dump_counters ppf t = Type.pp_json ~minify:false counters_t ppf t - - let fresh_counters () = + let fresh_counters _ = { contents_hash = 0; contents_add = 0; @@ -98,21 +96,18 @@ module Make (P : Backend.S) = struct node_val_list = 0; } - let reset_counters t = - t.contents_hash <- 0; - t.contents_add <- 0; - t.contents_find <- 0; - t.contents_mem <- 0; - t.node_hash <- 0; - t.node_mem <- 0; - t.node_index <- 0; - t.node_add <- 0; - t.node_find <- 0; - t.node_val_v <- 0; - t.node_val_find <- 0; - t.node_val_list <- 0 - - let cnt = fresh_counters () + let cnt = Atomic.make (fresh_counters ()) + let counters () = Atomic.get cnt + + let rec update_cnt f = + let old = Atomic.get cnt in + let cnt' = f old in + if not @@ Atomic.compare_and_set cnt old cnt' then update_cnt f + + let reset_counters () = update_cnt fresh_counters + + let dump_counters ppf _ = + Type.pp_json ~minify:false counters_t ppf (Atomic.get cnt) module Path = struct include P.Node.Path @@ -314,7 +309,8 @@ module Make (P : Backend.S) = struct match cached_value c with | None -> assert false | Some v -> - cnt.contents_hash <- cnt.contents_hash + 1; + update_cnt (fun cnt -> + { cnt with contents_hash = succ cnt.contents_hash }); let h = P.Contents.Hash.hash v in assert (c.info.ptr = Ptr_none); if cache then c.info.ptr <- Hash h; @@ -324,7 +320,8 @@ module Make (P : Backend.S) = struct match t.v with Key (_, k) -> Some k | Value _ | Pruned _ -> None let value_of_key ~cache t repo k = - cnt.contents_find <- cnt.contents_find + 1; + update_cnt (fun cnt -> + { cnt with contents_find = succ cnt.contents_find }); let h = P.Contents.Key.to_hash k in let v_opt = P.Contents.find (P.Repo.contents_t repo) k in Option.iter (Env.add_contents_from_store t.info.env h) v_opt; @@ -572,7 +569,8 @@ module Make (P : Backend.S) = struct end) = struct let to_map ~cache ~env repo t = - cnt.node_val_list <- cnt.node_val_list + 1; + update_cnt (fun cnt -> + { cnt with node_val_list = succ cnt.node_val_list }); let entries = N.seq ~cache t in Seq.fold_left (fun acc (k, v) -> StepMap.add k (To_elt.t ~env repo v) acc) @@ -597,7 +595,8 @@ module Make (P : Backend.S) = struct else ( (* Starting from this point the function is expensive, but there is no alternative. *) - cnt.node_val_list <- cnt.node_val_list + 1; + update_cnt (fun cnt -> + { cnt with node_val_list = succ cnt.node_val_list }); let entries = N.seq ~cache t in Seq.for_all (fun (step, _) -> StepMap.mem step um) entries) @@ -610,7 +609,8 @@ module Make (P : Backend.S) = struct Some tree let seq ~env ?offset ?length ~cache repo v = - cnt.node_val_list <- cnt.node_val_list + 1; + update_cnt (fun cnt -> + { cnt with node_val_list = succ cnt.node_val_list }); let seq = N.seq ?offset ?length ~cache v in Seq.map (fun (k, v) -> (k, To_elt.t ~env repo v)) seq end @@ -830,7 +830,7 @@ module Make (P : Backend.S) = struct let rec hash : type a. cache:bool -> t -> (hash -> a) -> a = fun ~cache t k -> let a_of_hashable hash v = - cnt.node_hash <- cnt.node_hash + 1; + update_cnt (fun cnt -> { cnt with node_hash = succ cnt.node_hash }); let hash = hash v in assert (t.info.ptr = Ptr_none); if cache then t.info.ptr <- Hash hash; @@ -858,7 +858,7 @@ module Make (P : Backend.S) = struct and hash_preimage_of_map : type r. cache:bool -> t -> map -> (hash_preimage, r) cont = fun ~cache t map k -> - cnt.node_val_v <- cnt.node_val_v + 1; + update_cnt (fun cnt -> { cnt with node_val_v = succ cnt.node_val_v }); let bindings = StepMap.to_seq map in let must_build_portable_node = bindings @@ -951,7 +951,7 @@ module Make (P : Backend.S) = struct match cached_value t with | Some v -> ok v | None -> ( - cnt.node_find <- cnt.node_find + 1; + update_cnt (fun cnt -> { cnt with node_find = succ cnt.node_find }); let v_opt = P.Node.find (P.Repo.node_t repo) k in let h = P.Node.Key.to_hash k in let v_opt = Option.map (Env.add_node_from_store t.info.env h) v_opt in @@ -1971,14 +1971,15 @@ module Make (P : Backend.S) = struct let import repo = function | `Contents (k, m) -> ( - cnt.contents_mem <- cnt.contents_mem + 1; + update_cnt (fun cnt -> + { cnt with contents_mem = succ cnt.contents_mem }); P.Contents.mem (P.Repo.contents_t repo) k |> function | true -> let env = Env.empty () in Some (`Contents (Contents.of_key ~env repo k, m)) | false -> None) | `Node k -> ( - cnt.node_mem <- cnt.node_mem + 1; + update_cnt (fun cnt -> { cnt with node_mem = succ cnt.node_mem }); P.Node.mem (P.Repo.node_t repo) k |> function | true -> let env = Env.empty () in @@ -2013,7 +2014,7 @@ module Make (P : Backend.S) = struct in let add_node n v k = - cnt.node_add <- cnt.node_add + 1; + update_cnt (fun cnt -> { cnt with node_add = succ cnt.node_add }); let key = P.Node.add node_t v in let () = (* Sanity check: Did we just store the same hash as the one represented @@ -2039,7 +2040,7 @@ module Make (P : Backend.S) = struct let node = (* Since we traverse in post-order, all children of [x] have already been added. Thus, their keys are cached and we can retrieve them. *) - cnt.node_val_v <- cnt.node_val_v + 1; + update_cnt (fun cnt -> { cnt with node_val_v = succ cnt.node_val_v }); StepMap.to_seq x |> Seq.map (fun (step, v) -> match v with @@ -2137,7 +2138,8 @@ module Make (P : Backend.S) = struct reason (not benched). *) k key else ( - cnt.node_mem <- cnt.node_mem + 1; + update_cnt (fun cnt -> + { cnt with node_mem = succ cnt.node_mem }); let mem = P.Node.mem node_t key in if not mem then (* Case 6. [n] contains a key that is not known by [repo]. @@ -2153,7 +2155,8 @@ module Make (P : Backend.S) = struct (* No pre-computed hash. *) None | Some h -> ( - cnt.node_index <- cnt.node_index + 1; + update_cnt (fun cnt -> + { cnt with node_index = succ cnt.node_index }); P.Node.index node_t h |> function | None -> (* Pre-computed hash is unknown by repo. @@ -2164,7 +2167,8 @@ module Make (P : Backend.S) = struct correctness, but does waste space. *) None | Some key -> - cnt.node_mem <- cnt.node_mem + 1; + update_cnt (fun cnt -> + { cnt with node_mem = succ cnt.node_mem }); let mem = P.Node.mem node_t key in if mem then (* Case 8. The pre-computed hash is converted into @@ -2219,7 +2223,8 @@ module Make (P : Backend.S) = struct | Contents.Value _ -> let v = Contents.to_value ~cache c in let v = get_ok "export" v in - cnt.contents_add <- cnt.contents_add + 1; + update_cnt (fun cnt -> + { cnt with contents_add = succ cnt.contents_add }); let key = P.Contents.add contents_t v in let () = let h = P.Contents.Key.to_hash key in @@ -2490,10 +2495,6 @@ module Make (P : Backend.S) = struct let post _ _ acc = acc in fold ~force ~cache ~pre ~post ~contents t empty_stats - let counters () = cnt - let dump_counters ppf () = dump_counters ppf cnt - let reset_counters () = reset_counters cnt - let inspect = function | `Contents _ -> `Contents | `Node n -> From 6afc95cadd96b6a3ba2135f00c3ccb0d7dda81fd Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Mon, 5 Jun 2023 15:42:44 +0200 Subject: [PATCH 31/99] Fixed again stats, this time not in unix --- src/irmin-pack/stats.ml | 65 ++++++++++++++++++++++------------------ src/irmin-pack/stats.mli | 18 +++++------ 2 files changed, 45 insertions(+), 38 deletions(-) diff --git a/src/irmin-pack/stats.ml b/src/irmin-pack/stats.ml index 6dc2aeda46..ef6875dd85 100644 --- a/src/irmin-pack/stats.ml +++ b/src/irmin-pack/stats.ml @@ -31,15 +31,15 @@ module Inode = struct | Inode_encode_bin type t = { - mutable inode_add : int; - mutable inode_remove : int; - mutable inode_of_seq : int; - mutable inode_of_raw : int; - mutable inode_rec_add : int; - mutable inode_rec_remove : int; - mutable inode_to_binv : int; - mutable inode_decode_bin : int; - mutable inode_encode_bin : int; + inode_add : int; + inode_remove : int; + inode_of_seq : int; + inode_of_raw : int; + inode_rec_add : int; + inode_rec_remove : int; + inode_to_binv : int; + inode_decode_bin : int; + inode_encode_bin : int; } [@@deriving irmin] @@ -59,16 +59,20 @@ module Inode = struct } let clear m = - let v = Metrics.state m in - v.inode_add <- 0; - v.inode_remove <- 0; - v.inode_of_seq <- 0; - v.inode_of_raw <- 0; - v.inode_rec_add <- 0; - v.inode_rec_remove <- 0; - v.inode_to_binv <- 0; - v.inode_decode_bin <- 0; - v.inode_encode_bin <- 0 + let v = + { + inode_add = 0; + inode_remove = 0; + inode_of_seq = 0; + inode_of_raw = 0; + inode_rec_add = 0; + inode_rec_remove = 0; + inode_to_binv = 0; + inode_decode_bin = 0; + inode_encode_bin = 0; + } + in + Metrics.set_state m v let init () = let initial_state = create_inode () in @@ -79,17 +83,20 @@ module Inode = struct let update ~field pack = let f v = match field with - | Inode_add -> v.inode_add <- succ v.inode_add - | Inode_remove -> v.inode_remove <- succ v.inode_remove - | Inode_of_seq -> v.inode_of_seq <- succ v.inode_of_seq - | Inode_of_raw -> v.inode_of_raw <- succ v.inode_of_raw - | Inode_rec_add -> v.inode_rec_add <- succ v.inode_rec_add - | Inode_rec_remove -> v.inode_rec_remove <- succ v.inode_rec_remove - | Inode_to_binv -> v.inode_to_binv <- succ v.inode_to_binv - | Inode_decode_bin -> v.inode_decode_bin <- succ v.inode_decode_bin - | Inode_encode_bin -> v.inode_encode_bin <- succ v.inode_encode_bin + | Inode_add -> { v with inode_add = succ v.inode_add } + | Inode_remove -> { v with inode_remove = succ v.inode_remove } + | Inode_of_seq -> { v with inode_of_seq = succ v.inode_of_seq } + | Inode_of_raw -> { v with inode_of_raw = succ v.inode_of_raw } + | Inode_rec_add -> { v with inode_rec_add = succ v.inode_rec_add } + | Inode_rec_remove -> + { v with inode_rec_remove = succ v.inode_rec_remove } + | Inode_to_binv -> { v with inode_to_binv = succ v.inode_to_binv } + | Inode_decode_bin -> + { v with inode_decode_bin = succ v.inode_decode_bin } + | Inode_encode_bin -> + { v with inode_encode_bin = succ v.inode_encode_bin } in - let mut = Metrics.Mutate f in + let mut = Metrics.Replace f in Metrics.update pack mut end diff --git a/src/irmin-pack/stats.mli b/src/irmin-pack/stats.mli index 180c222787..a2548e269e 100644 --- a/src/irmin-pack/stats.mli +++ b/src/irmin-pack/stats.mli @@ -27,15 +27,15 @@ module Inode : sig | Inode_encode_bin type t = private { - mutable inode_add : int; - mutable inode_remove : int; - mutable inode_of_seq : int; - mutable inode_of_raw : int; - mutable inode_rec_add : int; - mutable inode_rec_remove : int; - mutable inode_to_binv : int; - mutable inode_decode_bin : int; - mutable inode_encode_bin : int; + inode_add : int; + inode_remove : int; + inode_of_seq : int; + inode_of_raw : int; + inode_rec_add : int; + inode_rec_remove : int; + inode_to_binv : int; + inode_decode_bin : int; + inode_encode_bin : int; } [@@deriving irmin] (** The type for stats for a store S. From 5b055c75d16365bd36d81d06b331e672015465f7 Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Mon, 12 Jun 2023 16:38:28 +0200 Subject: [PATCH 32/99] Update multicore testing --- test/multirmin/test.ml | 73 +++++++++++++++++++++++++++++------------- 1 file changed, 50 insertions(+), 23 deletions(-) diff --git a/test/multirmin/test.ml b/test/multirmin/test.ml index bce12544b5..504eea4a50 100644 --- a/test/multirmin/test.ml +++ b/test/multirmin/test.ml @@ -12,37 +12,64 @@ let config ?(readonly = false) ?(fresh = true) root = let info () = S.Info.empty -let do_the_do ro i = - let t = S.main ro in - let c = S.Head.get t in - match S.Commit.of_hash ro (S.Commit.hash c) with - | None -> failwith "no hash" - | Some commit -> - let tree = S.Commit.tree commit in - let x = S.Tree.find tree [ "a" ] in - if x <> Some "x" then failwith "RO find"; - Format.printf "Done: i:%d d:%d@." i (Domain.self () :> int) +let test_find repo i = + let tree = + repo + |> S.main + |> S.Head.get + |> S.Commit.hash + |> S.Commit.of_hash repo + |> Option.get + |> S.Commit.tree + in + let start_value = S.Tree.find tree [ "start" ] in + assert (start_value = Some "content-start"); + let str_i = string_of_int i in + let value = S.Tree.find tree [ str_i ] in + if not (value = Some ("content-" ^ str_i)) then + Format.printf "Couldn't read correct value from thread %d@." i + +let test_add repo i = + let main = S.main repo in + let tree = + main + |> S.Head.get + |> S.Commit.hash + |> S.Commit.of_hash repo + |> Option.get + |> S.Commit.tree + in + let str_i = string_of_int i in + let tree' = S.Tree.add tree [ str_i ] ("content-" ^ str_i) in + S.set_tree_exn ~info main [] tree'; + () let repeatedly_do fn arg () = for _ = 0 to 100 do Sys.opaque_identity (fn arg) done -let open_ro_after_rw_closed env = +let dispatch repo i () = + repeatedly_do + (if i mod 2 = 0 then (* Readers *) + test_find repo + else (* Writers *) test_add repo) + (i / 2) () + +let setup d_mgr = rm_dir root; - let rw = S.Repo.v (config ~readonly:false ~fresh:true root) in - let t = S.main rw in - let tree = S.Tree.singleton [ "a" ] "x" in - S.set_tree_exn ~parents:[] ~info t [] tree; - S.Repo.close rw; - let ro = S.Repo.v (config ~readonly:true ~fresh:false root) in - let l = - List.init 7 (fun i () -> - Eio.Domain_manager.run env (repeatedly_do (do_the_do ro) i)) + let repo = S.Repo.v (config ~readonly:false ~fresh:true root) in + let main = S.main repo in + let init = S.Tree.singleton [ "start" ] "content-start" in + S.set_tree_exn ~parents:[] ~info main [] init; + S.Repo.close repo; + let repo = S.Repo.v (config ~readonly:false ~fresh:false root) in + let fibers = + List.init 7 (fun i () -> Eio.Domain_manager.run d_mgr (dispatch repo i)) in - Eio.Fiber.all l; - S.Repo.close ro + Eio.Fiber.all fibers; + S.Repo.close repo let () = Logs.set_level None; - Eio_main.run @@ fun env -> open_ro_after_rw_closed env#domain_mgr + Eio_main.run @@ fun env -> setup env#domain_mgr From 2c2dffe4af7f912cb3c61dc489a714d8f9bcb2fd Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Mon, 19 Jun 2023 16:24:06 +0200 Subject: [PATCH 33/99] Added locks on unix/pack-store, in Tbl --- src/irmin-pack/unix/pack_store.ml | 28 +++++++++++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) diff --git a/src/irmin-pack/unix/pack_store.ml b/src/irmin-pack/unix/pack_store.ml index 019ffe29d2..8563a87ae4 100644 --- a/src/irmin-pack/unix/pack_store.ml +++ b/src/irmin-pack/unix/pack_store.ml @@ -24,13 +24,39 @@ exception Dangling_hash let invalid_read fmt = Fmt.kstr (fun s -> raise (Invalid_read s)) fmt let corrupted_store fmt = Fmt.kstr (fun s -> raise (Corrupted_store s)) fmt -module Table (K : Irmin.Hash.S) = Hashtbl.Make (struct +module UnsafeTbl (K : Irmin.Hash.S) = Hashtbl.Make (struct type t = K.t let hash = K.short_hash let equal = Irmin.Type.(unstage (equal K.t)) end) +(** Safe but might be incredibly slow. *) +module Table (K : Irmin.Hash.S) = struct + module Unsafe = UnsafeTbl (K) + + type 'a t = { lock : Eio.Mutex.t; data : 'a Unsafe.t } + + let create n = + let lock = Eio.Mutex.create () in + let data = Unsafe.create n in + { lock; data } + + let add { lock; data } k v = + Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.add data k v + + let mem { lock; data } k = + Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.mem data k + + let find_opt { lock; data } k = + Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.find_opt data k + + let find t k = match find_opt t k with Some v -> v | None -> raise Not_found + + let clear { lock; data } = + Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.clear data +end + module Make_without_close_checks (Fm : File_manager.S) (Dispatcher : Dispatcher.S with module Fm = Fm) From 878983c6a5deba89cfce2cb58a8eb490a9c0bb7f Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Mon, 19 Jun 2023 16:27:26 +0200 Subject: [PATCH 34/99] Added locks in irmin-pack atomic_write --- src/irmin-pack/unix/atomic_write.ml | 41 +++++++++++++++++++++++++++-- 1 file changed, 39 insertions(+), 2 deletions(-) diff --git a/src/irmin-pack/unix/atomic_write.ml b/src/irmin-pack/unix/atomic_write.ml index 378defb8d3..e3c60704ed 100644 --- a/src/irmin-pack/unix/atomic_write.ml +++ b/src/irmin-pack/unix/atomic_write.ml @@ -1,13 +1,50 @@ open Import include Irmin_pack.Atomic_write -module Table (K : Irmin.Type.S) = Hashtbl.Make (struct +let current_version = `V1 + +module UnsafeTbl (K : Irmin.Type.S) = Hashtbl.Make (struct type t = K.t [@@deriving irmin ~short_hash ~equal] let hash = short_hash ?seed:None end) -module Make_persistent (Io : Io.S) (K : Irmin.Type.S) (V : Value.S) = struct +(** Safe but might be incredibly slow. *) +module Table (K : Irmin.Type.S) = struct + module Unsafe = UnsafeTbl (K) + + type 'a t = { lock : Eio.Mutex.t; data : 'a Unsafe.t } + + let create n = + let lock = Eio.Mutex.create () in + let data = Unsafe.create n in + { lock; data } + + let add { lock; data } k v = + Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.add data k v + + let mem { lock; data } k = + Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.mem data k + + let find_opt { lock; data } k = + Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.find_opt data k + + let find t k = match find_opt t k with Some v -> v | None -> raise Not_found + + let replace { lock; data } k v = + Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.replace data k v + + let remove { lock; data } k = + Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.remove data k + + let reset { lock; data } = + Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.reset data + + let fold f { lock; data } init = + Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.fold f data init +end + +module Make_persistent (K : Irmin.Type.S) (V : Value.S) = struct module Tbl = Table (K) module W = Irmin.Backend.Watch.Make (K) (V) module Io_errors = Io_errors.Make (Io) From cff02a64d5bb619e98b8a2618f1a7689dbfd07a2 Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Mon, 19 Jun 2023 18:13:45 +0200 Subject: [PATCH 35/99] Added locks in control-file --- src/irmin-pack/unix/control_file.ml | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/src/irmin-pack/unix/control_file.ml b/src/irmin-pack/unix/control_file.ml index 289712505d..3cf57c4c9a 100644 --- a/src/irmin-pack/unix/control_file.ml +++ b/src/irmin-pack/unix/control_file.ml @@ -327,6 +327,7 @@ module Make (Serde : Serde.S) (Io : Io.S) = struct mutable payload : payload; path : string; tmp_path : string option; + lock : Eio.Mutex.t; } let write io payload = @@ -335,6 +336,7 @@ module Make (Serde : Serde.S) (Io : Io.S) = struct let set_payload t payload = let open Result_syntax in + Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> if Io.readonly t.io then Error `Ro_not_allowed else match t.tmp_path with @@ -354,22 +356,28 @@ module Make (Serde : Serde.S) (Io : Io.S) = struct let create_rw ~path ~tmp_path ~overwrite (payload : payload) = let open Result_syntax in + let lock = Eio.Mutex.create () in let* io = Io.create ~path ~overwrite in let+ () = write io payload in - { io; payload; path; tmp_path } + { io; payload; path; tmp_path; lock } let open_ ~path ~tmp_path ~readonly = let open Result_syntax in + let lock = Eio.Mutex.create () in let* io = Io.open_ ~path ~readonly in let+ payload = read io in - { io; payload; path; tmp_path } + { io; payload; path; tmp_path; lock } - let close t = Io.close t.io - let readonly t = Io.readonly t.io - let payload t = t.payload + let close t = Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> Io.close t.io + + let readonly t = + Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> Io.readonly t.io + + let payload t = Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> t.payload let reload t = let open Result_syntax in + Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> if not @@ Io.readonly t.io then Error `Rw_not_allowed else let* () = Io.close t.io in @@ -393,7 +401,7 @@ module Make (Serde : Serde.S) (Io : Io.S) = struct let+ () = Io.close io in payload - let fsync t = Io.fsync t.io + let fsync t = Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> Io.fsync t.io end module Upper = Make (Serde.Upper) From 0043f796086af9cd9021cb3f14784ffc9c2c860f Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Mon, 19 Jun 2023 18:14:14 +0200 Subject: [PATCH 36/99] Remove unsafe index stats in irmin-pack io --- src/irmin-pack/unix/io.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/irmin-pack/unix/io.ml b/src/irmin-pack/unix/io.ml index 971aec480f..958333d9ec 100644 --- a/src/irmin-pack/unix/io.ml +++ b/src/irmin-pack/unix/io.ml @@ -168,7 +168,8 @@ module Unix = struct usage is safe. *) let buf = Bytes.unsafe_of_string s in let () = Util.really_write t.fd off buf 0 len in - Index.Stats.add_write len; + (* Bad index usage! Not multicore-safe! + Index.Stats.add_write len; *) () let write_string t ~off s = From df498e4e153756e69e4c3380102db362f97341f9 Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Mon, 19 Jun 2023 18:16:28 +0200 Subject: [PATCH 37/99] Added locks in store --- src/irmin-pack/unix/store.ml | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/src/irmin-pack/unix/store.ml b/src/irmin-pack/unix/store.ml index 41303dfa8b..7d49df8c2b 100644 --- a/src/irmin-pack/unix/store.ml +++ b/src/irmin-pack/unix/store.ml @@ -156,6 +156,7 @@ module Maker (Config : Conf.S) = struct dispatcher : Dispatcher.t; mutable during_batch : bool; mutable running_gc : running_gc option; + lock : Eio.Mutex.t; } let pp_key = Irmin.Type.pp XKey.t @@ -198,6 +199,7 @@ module Maker (Config : Conf.S) = struct in let during_batch = false in let running_gc = None in + let lock = Eio.Mutex.create () in { config; contents; @@ -210,6 +212,7 @@ module Maker (Config : Conf.S) = struct running_gc; dispatcher; lru; + lock; } let flush t = File_manager.flush ?hook:None t.fm |> Errs.raise_if_error @@ -221,6 +224,7 @@ module Maker (Config : Conf.S) = struct let behaviour { fm; _ } = File_manager.gc_behaviour fm let cancel t = + Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> match t.running_gc with | Some { gc; _ } -> let cancelled = Gc.cancel gc in @@ -242,6 +246,7 @@ module Maker (Config : Conf.S) = struct let start ~unlink ~use_auto_finalisation ~output t commit_key = let open Result_syntax in + Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> [%log.info "GC: Starting on %a" pp_key commit_key]; let* () = if t.during_batch then Error `Gc_forbidden_during_batch else Ok () @@ -266,6 +271,7 @@ module Maker (Config : Conf.S) = struct let start_exn ?(unlink = true) ?(output = `Root) ~use_auto_finalisation t commit_key = + Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> match t.running_gc with | Some _ -> [%log.info "Repo is alreadying running GC. Skipping."]; @@ -277,6 +283,7 @@ module Maker (Config : Conf.S) = struct match result with Ok _ -> true | Error e -> Errs.raise_error e) let finalise_exn ?(wait = false) t = + Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> let result = match t.running_gc with | None -> Ok `Idle @@ -293,9 +300,12 @@ module Maker (Config : Conf.S) = struct t.running_gc <- None; Errs.raise_error e - let is_finished t = Option.is_none t.running_gc + let is_finished t = + Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> + Option.is_none t.running_gc let on_finalise t f = + Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> match t.running_gc with | None -> () | Some { gc; _ } -> Gc.on_finalise gc f @@ -354,6 +364,7 @@ module Maker (Config : Conf.S) = struct if not launched then Errs.raise_error `Forbidden_during_gc in let gced = + Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> match t.running_gc with | None -> assert false | Some { gc; _ } -> Gc.finalise_without_swap gc @@ -374,6 +385,7 @@ module Maker (Config : Conf.S) = struct let split t = let open Result_syntax in + Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> let readonly = Irmin_pack.Conf.readonly t.config in let* () = if not (is_split_allowed t) then Error `Split_disallowed else Ok () @@ -398,6 +410,7 @@ module Maker (Config : Conf.S) = struct let batch t f = [%log.debug "[pack] batch start"]; + Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> let readonly = Irmin_pack.Conf.readonly t.config in if readonly then Errs.raise_error `Ro_not_allowed else From 1a3678dfd89b7a839c4d6b81747ca6d91f762676 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Wed, 21 Jun 2023 21:46:40 +0200 Subject: [PATCH 38/99] Safe pack_key promotion --- src/irmin-pack/unix/pack_key.ml | 56 ++++++++++++++++++++------------- 1 file changed, 35 insertions(+), 21 deletions(-) diff --git a/src/irmin-pack/unix/pack_key.ml b/src/irmin-pack/unix/pack_key.ml index 444b1dbff4..1bb386a002 100644 --- a/src/irmin-pack/unix/pack_key.ml +++ b/src/irmin-pack/unix/pack_key.ml @@ -32,47 +32,54 @@ type (_, _) unsafe_state = | Offset : int63 -> ('hash, unsafe) unsafe_state type 'hash state = ('hash, safe) unsafe_state -type 'hash t = State : { mutable state : ('hash, _) unsafe_state } -> 'hash t +type 'hash t = State : { state : ('hash, _) unsafe_state Atomic.t } -> 'hash t let inspect (State t) = - match t.state with + match Atomic.get t.state with | Offset _ -> failwith "inspect unsafe Offset" | Direct d -> Direct d | Indexed d -> Indexed d let to_hash (State t) = - match t.state with + match Atomic.get t.state with | Direct t -> t.hash | Indexed h -> h | Offset _ -> failwith "Hash unavailable" let to_offset (State t) = - match t.state with + match Atomic.get t.state with | Direct t -> Some t.offset | Offset offset -> Some offset | Indexed _ -> None let to_length (State t) = - match t.state with + match Atomic.get t.state with | Direct t -> Some t.length | Offset _ -> None | Indexed _ -> None -let promote_exn ~offset ~length ?volume_identifier (State t) = - match t.state with - | Direct _ -> failwith "Attempted to promote a key that is already Direct" +let rec promote_exn ~offset ~length ?volume_identifier (State t) = + match Atomic.get t.state with + | Direct d -> + assert (d.offset = offset); + assert (d.length = length); + assert (d.volume_identifier = volume_identifier) | Offset _ -> failwith "Attempted to promote an offset without hash" - | Indexed hash -> - t.state <- Direct { hash; offset; length; volume_identifier } + | Indexed hash as old -> + let direct = Direct { hash; offset; length; volume_identifier } in + if not (Atomic.compare_and_set t.state old direct) then + promote_exn ~offset ~length ?volume_identifier (State t) -let set_volume_identifier_exn ~volume_identifier (State t) = - match t.state with +let rec set_volume_identifier_exn ~volume_identifier (State t) = + match Atomic.get t.state with | Indexed _ -> failwith "Attempted to set volume identifier to a key that is Indexed" | Offset _ -> failwith "Attempted to set volume identifier to an offset without hash" - | Direct { hash; offset; length; _ } -> - t.state <- Direct { hash; offset; length; volume_identifier } + | Direct { hash; offset; length; _ } as old -> + let direct = Direct { hash; offset; length; volume_identifier } in + if not (Atomic.compare_and_set t.state old direct) then + set_volume_identifier_exn ~volume_identifier (State t) let t : type h. h Irmin.Type.t -> h t Irmin.Type.t = fun hash_t -> @@ -83,8 +90,13 @@ let t : type h. h Irmin.Type.t -> h t Irmin.Type.t = | Indexed x1 -> indexed x1) |~ case1 "Direct" [%typ: hash * int63 * int] (fun (hash, offset, length) -> State - { state = Direct { hash; offset; length; volume_identifier = None } }) - |~ case1 "Indexed" [%typ: hash] (fun x1 -> State { state = Indexed x1 }) + { + state = + Atomic.make + (Direct { hash; offset; length; volume_identifier = None }); + }) + |~ case1 "Indexed" [%typ: hash] (fun x1 -> + State { state = Atomic.make (Indexed x1) }) |> sealv let t (type hash) (hash_t : hash Irmin.Type.t) = @@ -118,10 +130,11 @@ let t (type hash) (hash_t : hash Irmin.Type.t) = let encode_bin t f = Hash.encode_bin (to_hash t) f in let unboxed_encode_bin t f = Hash.unboxed_encode_bin (to_hash t) f in let decode_bin buf pos_ref = - State { state = Indexed (Hash.decode_bin buf pos_ref) } + State { state = Atomic.make (Indexed (Hash.decode_bin buf pos_ref)) } in let unboxed_decode_bin buf pos_ref = - State { state = Indexed (Hash.unboxed_decode_bin buf pos_ref) } + State + { state = Atomic.make (Indexed (Hash.unboxed_decode_bin buf pos_ref)) } in let size_of = Irmin.Type.Size.custom_static Hash.encoded_size in Irmin.Type.like (t hash_t) ~pre_hash ~equal ~compare @@ -129,10 +142,11 @@ let t (type hash) (hash_t : hash Irmin.Type.t) = ~unboxed_bin:(unboxed_encode_bin, unboxed_decode_bin, size_of) let v_direct ~offset ~length ?volume_identifier hash = - State { state = Direct { hash; offset; length; volume_identifier } } + State + { state = Atomic.make (Direct { hash; offset; length; volume_identifier }) } -let v_indexed hash = State { state = Indexed hash } -let v_offset offset = State { state = Offset offset } +let v_indexed hash = State { state = Atomic.make (Indexed hash) } +let v_offset offset = State { state = Atomic.make (Offset offset) } module type S = sig type hash From 7972f9dfb13ff456fe0b733e410e1c6ad962a48b Mon Sep 17 00:00:00 2001 From: ArthurW Date: Thu, 22 Jun 2023 14:14:05 +0200 Subject: [PATCH 39/99] Optimize control file payload --- src/irmin-pack/unix/control_file.ml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/irmin-pack/unix/control_file.ml b/src/irmin-pack/unix/control_file.ml index 3cf57c4c9a..2eab42867a 100644 --- a/src/irmin-pack/unix/control_file.ml +++ b/src/irmin-pack/unix/control_file.ml @@ -324,7 +324,7 @@ module Make (Serde : Serde.S) (Io : Io.S) = struct type t = { mutable io : Io.t; - mutable payload : payload; + payload : payload Atomic.t; path : string; tmp_path : string option; lock : Eio.Mutex.t; @@ -347,7 +347,7 @@ module Make (Serde : Serde.S) (Io : Io.S) = struct t.io <- io_tmp; let* () = write io_tmp payload in let+ () = Io.move_file ~src:tmp_path ~dst:t.path in - t.payload <- payload + Atomic.set t.payload payload let read io = let open Result_syntax in @@ -359,21 +359,21 @@ module Make (Serde : Serde.S) (Io : Io.S) = struct let lock = Eio.Mutex.create () in let* io = Io.create ~path ~overwrite in let+ () = write io payload in - { io; payload; path; tmp_path; lock } + { io; payload = Atomic.make payload; path; tmp_path; lock } let open_ ~path ~tmp_path ~readonly = let open Result_syntax in let lock = Eio.Mutex.create () in let* io = Io.open_ ~path ~readonly in let+ payload = read io in - { io; payload; path; tmp_path; lock } + { io; payload = Atomic.make payload; path; tmp_path; lock } let close t = Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> Io.close t.io let readonly t = Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> Io.readonly t.io - let payload t = Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> t.payload + let payload t = Atomic.get t.payload let reload t = let open Result_syntax in @@ -384,7 +384,7 @@ module Make (Serde : Serde.S) (Io : Io.S) = struct let* io = Io.open_ ~path:t.path ~readonly:true in t.io <- io; let+ payload = read io in - t.payload <- payload + Atomic.set t.payload payload let read_payload ~path = let open Result_syntax in From ea0689726b04249adbad58c332058def4bed3dd2 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Thu, 22 Jun 2023 14:16:00 +0200 Subject: [PATCH 40/99] Remove unsafe usage of Index.Stats --- src/irmin-pack/unix/io.ml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/irmin-pack/unix/io.ml b/src/irmin-pack/unix/io.ml index 958333d9ec..fb9c92851a 100644 --- a/src/irmin-pack/unix/io.ml +++ b/src/irmin-pack/unix/io.ml @@ -168,7 +168,7 @@ module Unix = struct usage is safe. *) let buf = Bytes.unsafe_of_string s in let () = Util.really_write t.fd off buf 0 len in - (* Bad index usage! Not multicore-safe! + (* TODO: Index.Stats is not domain-safe Index.Stats.add_write len; *) () @@ -195,7 +195,8 @@ module Unix = struct | true -> raise Errors.Closed | false -> let nread = Util.really_read t.fd off len buf in - Index.Stats.add_read nread; + (* TODO: Index.Stats is not domain-safe + Index.Stats.add_read nread; *) if nread <> len then (* didn't manage to read the desired amount; in this case the interface seems to require we return `Read_out_of_bounds FIXME check this, because it is unusual @@ -231,7 +232,8 @@ module Unix = struct ~length:len in if nread > 0 then ( - Index.Stats.add_read nread; + (* TODO: Index.Stats is not domain-safe + Index.Stats.add_read nread; *) Buffer.add_subbytes buf bytes 0 nread; if nread = len then aux ~off:Int63.(add off (of_int nread))) in From c90c0596c12cc474ccd436a8c30943247feb70db Mon Sep 17 00:00:00 2001 From: ArthurW Date: Fri, 23 Jun 2023 13:51:14 +0200 Subject: [PATCH 41/99] Fix Tree findv_cache --- src/irmin/tree.ml | 32 +++++++++++++++++++++----------- 1 file changed, 21 insertions(+), 11 deletions(-) diff --git a/src/irmin/tree.ml b/src/irmin/tree.ml index 50ba1752df..6976ad4565 100644 --- a/src/irmin/tree.ml +++ b/src/irmin/tree.ml @@ -415,7 +415,7 @@ module Make (P : Backend.S) = struct mutable value : value option; mutable map : map option; mutable ptr : ptr_option; - mutable findv_cache : map option; + findv_cache : map option Atomic.t; mutable length : int Lazy.t option; env : Env.t; } @@ -487,7 +487,7 @@ module Make (P : Backend.S) = struct | Value (_, v, None) -> (Ptr_none, None, Some v) | Value _ | Portable_dirty _ | Pruned _ -> (Ptr_none, None, None) in - let findv_cache = None in + let findv_cache = Atomic.make None in let info = { ptr; map; value; findv_cache; env; length } in { v; info } @@ -501,19 +501,27 @@ module Make (P : Backend.S) = struct let pruned h = of_v (Pruned h) let info_is_empty i = - i.map = None && i.value = None && i.findv_cache = None && i.ptr = Ptr_none - - let add_to_findv_cache t step v = - match t.info.findv_cache with - | None -> t.info.findv_cache <- Some (StepMap.singleton step v) - | Some m -> t.info.findv_cache <- Some (StepMap.add step v m) + i.map = None + && i.value = None + && Atomic.get i.findv_cache = None + && i.ptr = Ptr_none + + let rec add_to_findv_cache t step v = + let old_value = Atomic.get t.info.findv_cache in + let new_value = + match old_value with + | None -> Some (StepMap.singleton step v) + | Some m -> Some (StepMap.add step v m) + in + if not (Atomic.compare_and_set t.info.findv_cache old_value new_value) + then add_to_findv_cache t step v let clear_info_fields i = if not (info_is_empty i) then ( i.value <- None; i.map <- None; i.ptr <- Ptr_none; - i.findv_cache <- None) + Atomic.set i.findv_cache None) let rec clear_elt ~max_depth depth v = match v with @@ -537,7 +545,9 @@ module Make (P : Backend.S) = struct | (Key _ | Value _ | Portable_dirty _ | Pruned _), None -> () in let () = - match i.findv_cache with Some m -> StepMap.iter clear m | None -> () + match Atomic.get i.findv_cache with + | Some m -> StepMap.iter clear m + | None -> () in if depth >= max_depth then clear_info_fields i @@ -1226,7 +1236,7 @@ module Make (P : Backend.S) = struct | None -> of_portable p) | Pruned h -> pruned_hash_exn ctx h in - match t.info.findv_cache with + match Atomic.get t.info.findv_cache with | None -> of_t () | Some m -> ( match of_map m with None -> of_t () | Some _ as r -> r) From 37086e62bfc02ebfdf600902121330a8b9471348 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Fri, 23 Jun 2023 13:54:55 +0200 Subject: [PATCH 42/99] Fix Tree value cache --- src/irmin/tree.ml | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/src/irmin/tree.ml b/src/irmin/tree.ml index 6976ad4565..b9d99e2ae2 100644 --- a/src/irmin/tree.ml +++ b/src/irmin/tree.ml @@ -412,7 +412,7 @@ module Make (P : Backend.S) = struct and map = elt StepMap.t and info = { - mutable value : value option; + value : value option Atomic.t; mutable map : map option; mutable ptr : ptr_option; findv_cache : map option Atomic.t; @@ -487,6 +487,7 @@ module Make (P : Backend.S) = struct | Value (_, v, None) -> (Ptr_none, None, Some v) | Value _ | Portable_dirty _ | Pruned _ -> (Ptr_none, None, None) in + let value = Atomic.make value in let findv_cache = Atomic.make None in let info = { ptr; map; value; findv_cache; env; length } in { v; info } @@ -502,7 +503,7 @@ module Make (P : Backend.S) = struct let info_is_empty i = i.map = None - && i.value = None + && Atomic.get i.value = None && Atomic.get i.findv_cache = None && i.ptr = Ptr_none @@ -518,7 +519,7 @@ module Make (P : Backend.S) = struct let clear_info_fields i = if not (info_is_empty i) then ( - i.value <- None; + Atomic.set i.value None; i.map <- None; i.ptr <- Ptr_none; Atomic.set i.findv_cache None) @@ -675,7 +676,7 @@ module Make (P : Backend.S) = struct miss t miss_arg let iter_value t hit miss miss_arg = - match (t.v, t.info.value) with + match (t.v, Atomic.get t.info.value) with | Value (_, v, None), None -> hit v | (Map _ | Key _ | Value _ | Portable_dirty _ | Pruned _), Some v -> hit v @@ -707,7 +708,7 @@ module Make (P : Backend.S) = struct | (Map _ | Portable_dirty _ | Pruned _ | Value _), _ -> miss t miss_arg let iter_repo_value t hit miss miss_arg = - match (t.v, t.info.value) with + match (t.v, Atomic.get t.info.value) with | Value (repo, v, None), _ -> hit repo v | (Value (repo, _, _) | Key (repo, _)), Some v -> hit repo v | (Value (repo, _, _) | Key (repo, _)), None -> @@ -906,7 +907,7 @@ module Make (P : Backend.S) = struct assert false)) |> P.Node.Val.of_seq in - if cache then t.info.value <- Some node; + if cache then Atomic.set t.info.value (Some node); k (Node node) and hash_preimage_value_of_elt : @@ -931,7 +932,9 @@ module Make (P : Backend.S) = struct let rec aux acc = function | [] -> (if cache then - match acc with Node n -> t.info.value <- Some n | Pnode _ -> ()); + match acc with + | Node n -> Atomic.set t.info.value (Some n) + | Pnode _ -> ()); k acc | (k, Add e) :: rest -> hash_preimage_value_of_elt ~cache e (fun e -> @@ -968,7 +971,7 @@ module Make (P : Backend.S) = struct match v_opt with | None -> err_dangling_hash h | Some v -> - if cache then t.info.value <- v_opt; + if cache then Atomic.set t.info.value v_opt; Ok v) let to_value ~cache t = From 8aeb8b8445981af2ca2d77470101b85e4b42b496 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Fri, 23 Jun 2023 14:10:12 +0200 Subject: [PATCH 43/99] Remove spinlock on Tree stats --- src/irmin/tree.ml | 157 ++++++++++++++++++++++++----------------- src/irmin/tree_intf.ml | 24 +++---- 2 files changed, 106 insertions(+), 75 deletions(-) diff --git a/src/irmin/tree.ml b/src/irmin/tree.ml index b9d99e2ae2..6eced9b7f8 100644 --- a/src/irmin/tree.ml +++ b/src/irmin/tree.ml @@ -64,50 +64,91 @@ let backend_invariant_violation fmt = let assertion_failure fmt = Fmt.kstr (fun s -> raise (Assertion_failure s)) fmt module Make (P : Backend.S) = struct - type counters = { - mutable contents_hash : int; - mutable contents_find : int; - mutable contents_add : int; - mutable contents_mem : int; - mutable node_hash : int; - mutable node_mem : int; - mutable node_index : int; - mutable node_add : int; - mutable node_find : int; - mutable node_val_v : int; - mutable node_val_find : int; - mutable node_val_list : int; + type counters_atomic = { + contents_hash : int Atomic.t; + contents_find : int Atomic.t; + contents_add : int Atomic.t; + contents_mem : int Atomic.t; + node_hash : int Atomic.t; + node_mem : int Atomic.t; + node_index : int Atomic.t; + node_add : int Atomic.t; + node_find : int Atomic.t; + node_val_v : int Atomic.t; + node_val_find : int Atomic.t; + node_val_list : int Atomic.t; } - [@@deriving irmin] let fresh_counters _ = { - contents_hash = 0; - contents_add = 0; - contents_find = 0; - contents_mem = 0; - node_hash = 0; - node_mem = 0; - node_index = 0; - node_add = 0; - node_find = 0; - node_val_v = 0; - node_val_find = 0; - node_val_list = 0; + contents_hash = Atomic.make 0; + contents_add = Atomic.make 0; + contents_find = Atomic.make 0; + contents_mem = Atomic.make 0; + node_hash = Atomic.make 0; + node_mem = Atomic.make 0; + node_index = Atomic.make 0; + node_add = Atomic.make 0; + node_find = Atomic.make 0; + node_val_v = Atomic.make 0; + node_val_find = Atomic.make 0; + node_val_list = Atomic.make 0; } - let cnt = Atomic.make (fresh_counters ()) - let counters () = Atomic.get cnt - - let rec update_cnt f = - let old = Atomic.get cnt in - let cnt' = f old in - if not @@ Atomic.compare_and_set cnt old cnt' then update_cnt f - - let reset_counters () = update_cnt fresh_counters + let cnt = fresh_counters () + + let reset_counters () = + Atomic.set cnt.contents_hash 0; + Atomic.set cnt.contents_add 0; + Atomic.set cnt.contents_find 0; + Atomic.set cnt.contents_mem 0; + Atomic.set cnt.node_hash 0; + Atomic.set cnt.node_mem 0; + Atomic.set cnt.node_index 0; + Atomic.set cnt.node_add 0; + Atomic.set cnt.node_find 0; + Atomic.set cnt.node_val_v 0; + Atomic.set cnt.node_val_find 0; + Atomic.set cnt.node_val_list 0 + + module Perf_counters = struct + type counters = { + contents_hash : int; + contents_find : int; + contents_add : int; + contents_mem : int; + node_hash : int; + node_mem : int; + node_index : int; + node_add : int; + node_find : int; + node_val_v : int; + node_val_find : int; + node_val_list : int; + } + [@@deriving irmin] + + let counters () = + { + contents_hash = Atomic.get cnt.contents_hash; + contents_add = Atomic.get cnt.contents_add; + contents_find = Atomic.get cnt.contents_find; + contents_mem = Atomic.get cnt.contents_mem; + node_hash = Atomic.get cnt.node_hash; + node_mem = Atomic.get cnt.node_mem; + node_index = Atomic.get cnt.node_index; + node_add = Atomic.get cnt.node_add; + node_find = Atomic.get cnt.node_find; + node_val_v = Atomic.get cnt.node_val_v; + node_val_find = Atomic.get cnt.node_val_find; + node_val_list = Atomic.get cnt.node_val_list; + } + + let dump_counters ppf _ = + Type.pp_json ~minify:false counters_t ppf (counters ()) + end - let dump_counters ppf _ = - Type.pp_json ~minify:false counters_t ppf (Atomic.get cnt) + include Perf_counters module Path = struct include P.Node.Path @@ -309,8 +350,7 @@ module Make (P : Backend.S) = struct match cached_value c with | None -> assert false | Some v -> - update_cnt (fun cnt -> - { cnt with contents_hash = succ cnt.contents_hash }); + Atomic.incr cnt.contents_hash; let h = P.Contents.Hash.hash v in assert (c.info.ptr = Ptr_none); if cache then c.info.ptr <- Hash h; @@ -320,8 +360,7 @@ module Make (P : Backend.S) = struct match t.v with Key (_, k) -> Some k | Value _ | Pruned _ -> None let value_of_key ~cache t repo k = - update_cnt (fun cnt -> - { cnt with contents_find = succ cnt.contents_find }); + Atomic.incr cnt.contents_find; let h = P.Contents.Key.to_hash k in let v_opt = P.Contents.find (P.Repo.contents_t repo) k in Option.iter (Env.add_contents_from_store t.info.env h) v_opt; @@ -580,8 +619,7 @@ module Make (P : Backend.S) = struct end) = struct let to_map ~cache ~env repo t = - update_cnt (fun cnt -> - { cnt with node_val_list = succ cnt.node_val_list }); + Atomic.incr cnt.node_val_list; let entries = N.seq ~cache t in Seq.fold_left (fun acc (k, v) -> StepMap.add k (To_elt.t ~env repo v) acc) @@ -606,8 +644,7 @@ module Make (P : Backend.S) = struct else ( (* Starting from this point the function is expensive, but there is no alternative. *) - update_cnt (fun cnt -> - { cnt with node_val_list = succ cnt.node_val_list }); + Atomic.incr cnt.node_val_list; let entries = N.seq ~cache t in Seq.for_all (fun (step, _) -> StepMap.mem step um) entries) @@ -620,8 +657,7 @@ module Make (P : Backend.S) = struct Some tree let seq ~env ?offset ?length ~cache repo v = - update_cnt (fun cnt -> - { cnt with node_val_list = succ cnt.node_val_list }); + Atomic.incr cnt.node_val_list; let seq = N.seq ?offset ?length ~cache v in Seq.map (fun (k, v) -> (k, To_elt.t ~env repo v)) seq end @@ -841,7 +877,7 @@ module Make (P : Backend.S) = struct let rec hash : type a. cache:bool -> t -> (hash -> a) -> a = fun ~cache t k -> let a_of_hashable hash v = - update_cnt (fun cnt -> { cnt with node_hash = succ cnt.node_hash }); + Atomic.incr cnt.node_hash; let hash = hash v in assert (t.info.ptr = Ptr_none); if cache then t.info.ptr <- Hash hash; @@ -869,7 +905,7 @@ module Make (P : Backend.S) = struct and hash_preimage_of_map : type r. cache:bool -> t -> map -> (hash_preimage, r) cont = fun ~cache t map k -> - update_cnt (fun cnt -> { cnt with node_val_v = succ cnt.node_val_v }); + Atomic.incr cnt.node_val_v; let bindings = StepMap.to_seq map in let must_build_portable_node = bindings @@ -964,7 +1000,7 @@ module Make (P : Backend.S) = struct match cached_value t with | Some v -> ok v | None -> ( - update_cnt (fun cnt -> { cnt with node_find = succ cnt.node_find }); + Atomic.incr cnt.node_find; let v_opt = P.Node.find (P.Repo.node_t repo) k in let h = P.Node.Key.to_hash k in let v_opt = Option.map (Env.add_node_from_store t.info.env h) v_opt in @@ -1984,15 +2020,14 @@ module Make (P : Backend.S) = struct let import repo = function | `Contents (k, m) -> ( - update_cnt (fun cnt -> - { cnt with contents_mem = succ cnt.contents_mem }); + Atomic.incr cnt.contents_mem; P.Contents.mem (P.Repo.contents_t repo) k |> function | true -> let env = Env.empty () in Some (`Contents (Contents.of_key ~env repo k, m)) | false -> None) | `Node k -> ( - update_cnt (fun cnt -> { cnt with node_mem = succ cnt.node_mem }); + Atomic.incr cnt.node_mem; P.Node.mem (P.Repo.node_t repo) k |> function | true -> let env = Env.empty () in @@ -2027,7 +2062,7 @@ module Make (P : Backend.S) = struct in let add_node n v k = - update_cnt (fun cnt -> { cnt with node_add = succ cnt.node_add }); + Atomic.incr cnt.node_add; let key = P.Node.add node_t v in let () = (* Sanity check: Did we just store the same hash as the one represented @@ -2053,7 +2088,7 @@ module Make (P : Backend.S) = struct let node = (* Since we traverse in post-order, all children of [x] have already been added. Thus, their keys are cached and we can retrieve them. *) - update_cnt (fun cnt -> { cnt with node_val_v = succ cnt.node_val_v }); + Atomic.incr cnt.node_val_v; StepMap.to_seq x |> Seq.map (fun (step, v) -> match v with @@ -2151,8 +2186,7 @@ module Make (P : Backend.S) = struct reason (not benched). *) k key else ( - update_cnt (fun cnt -> - { cnt with node_mem = succ cnt.node_mem }); + Atomic.incr cnt.node_mem; let mem = P.Node.mem node_t key in if not mem then (* Case 6. [n] contains a key that is not known by [repo]. @@ -2168,8 +2202,7 @@ module Make (P : Backend.S) = struct (* No pre-computed hash. *) None | Some h -> ( - update_cnt (fun cnt -> - { cnt with node_index = succ cnt.node_index }); + Atomic.incr cnt.node_index; P.Node.index node_t h |> function | None -> (* Pre-computed hash is unknown by repo. @@ -2180,8 +2213,7 @@ module Make (P : Backend.S) = struct correctness, but does waste space. *) None | Some key -> - update_cnt (fun cnt -> - { cnt with node_mem = succ cnt.node_mem }); + Atomic.incr cnt.node_mem; let mem = P.Node.mem node_t key in if mem then (* Case 8. The pre-computed hash is converted into @@ -2236,8 +2268,7 @@ module Make (P : Backend.S) = struct | Contents.Value _ -> let v = Contents.to_value ~cache c in let v = get_ok "export" v in - update_cnt (fun cnt -> - { cnt with contents_add = succ cnt.contents_add }); + Atomic.incr cnt.contents_add; let key = P.Contents.add contents_t v in let () = let h = P.Contents.Key.to_hash key in diff --git a/src/irmin/tree_intf.ml b/src/irmin/tree_intf.ml index cd572d23af..cb5004af61 100644 --- a/src/irmin/tree_intf.ml +++ b/src/irmin/tree_intf.ml @@ -376,18 +376,18 @@ module type S = sig (** {1 Performance counters} *) type counters = { - mutable contents_hash : int; - mutable contents_find : int; - mutable contents_add : int; - mutable contents_mem : int; - mutable node_hash : int; - mutable node_mem : int; - mutable node_index : int; - mutable node_add : int; - mutable node_find : int; - mutable node_val_v : int; - mutable node_val_find : int; - mutable node_val_list : int; + contents_hash : int; + contents_find : int; + contents_add : int; + contents_mem : int; + node_hash : int; + node_mem : int; + node_index : int; + node_add : int; + node_find : int; + node_val_v : int; + node_val_find : int; + node_val_list : int; } val counters : unit -> counters From 8bcd565a208ffa1d97603320e7681515a39c1abc Mon Sep 17 00:00:00 2001 From: ArthurW Date: Fri, 23 Jun 2023 14:22:55 +0200 Subject: [PATCH 44/99] Fix irmin-pack inode partial_ptr --- src/irmin-pack/inode.ml | 89 ++++++++++++++++++++++------------------- 1 file changed, 47 insertions(+), 42 deletions(-) diff --git a/src/irmin-pack/inode.ml b/src/irmin-pack/inode.ml index 64723f4746..3e35528a9f 100644 --- a/src/irmin-pack/inode.ml +++ b/src/irmin-pack/inode.ml @@ -620,7 +620,7 @@ struct e.g. through the [add] or [to_concrete] functions. It shouldn't be collected on [clear] because it will be needed for [save]. *) - and partial_ptr = { mutable target : partial_ptr_target } + and partial_ptr = { target : partial_ptr_target Atomic.t } [@@unboxed] and total_ptr = Total_ptr of total_ptr t [@@unboxed] and truncated_ptr = @@ -646,7 +646,7 @@ struct | Total -> fun (Total_ptr ptr) -> ptr.v_ref | Partial _ -> ( fun { target } -> - match target with + match Atomic.get target with | Lazy key -> Val_ref.of_key key | Lazy_loaded { v_ref; _ } | Dirty { v_ref; _ } -> v_ref) | Truncated -> ( function Broken v -> v | Intact ptr -> ptr.v_ref) @@ -655,7 +655,7 @@ struct | Total -> fun (Total_ptr ptr) -> Val_ref.to_key_exn ptr.v_ref | Partial _ -> ( fun { target } -> - match target with + match Atomic.get target with | Lazy key -> key | Lazy_loaded { v_ref; _ } | Dirty { v_ref; _ } -> Val_ref.to_key_exn v_ref) @@ -680,20 +680,23 @@ struct match layout with | Total -> fun (Total_ptr t) -> t | Partial find -> ( - function - | { target = Dirty entry } | { target = Lazy_loaded entry } -> - (* [target] is already cached. [cache] is only concerned with - new cache entries, not the older ones for which the irmin - users can discard using [clear]. *) - entry - | { target = Lazy key } as t -> ( - if not force then raise_dangling_hash context (Key.to_hash key); - match find ~expected_depth key with - | None -> - Fmt.failwith "%a: unknown inode key (%s)" pp_key key context - | Some x -> - if cache then t.target <- Lazy_loaded x; - x)) + fun { target } -> + match Atomic.get target with + | Dirty entry | Lazy_loaded entry -> + (* [target] is already cached. [cache] is only concerned with + new cache entries, not the older ones for which the irmin + users can discard using [clear]. *) + entry + | Lazy key -> ( + if not force then + raise_dangling_hash context (Key.to_hash key); + match find ~expected_depth key with + | None -> + Fmt.failwith "%a: unknown inode key (%s)" pp_key key + context + | Some x -> + if cache then Atomic.set target (Lazy_loaded x); + x)) | Truncated -> ( function | Intact entry -> entry @@ -703,12 +706,12 @@ struct let of_target : type ptr. ptr layout -> ptr t -> ptr = function | Total -> fun target -> Total_ptr target - | Partial _ -> fun target -> { target = Dirty target } + | Partial _ -> fun target -> { target = Atomic.make (Dirty target) } | Truncated -> fun target -> Intact target let of_key : type ptr. ptr layout -> key -> ptr = function | Total -> assert false - | Partial _ -> fun key -> { target = Lazy key } + | Partial _ -> fun key -> { target = Atomic.make (Lazy key) } | Truncated -> fun key -> Broken (Val_ref.of_key key) type ('input, 'output) cps = { f : 'r. 'input -> ('output -> 'r) -> 'r } @@ -732,23 +735,24 @@ struct save_dirty.f entry (fun key -> Val_ref.promote_exn entry.v_ref key) | Partial _ -> ( - function - | { target = Dirty entry } as box -> - save_dirty.f entry (fun key -> - if clear then box.target <- Lazy key - else ( - box.target <- Lazy_loaded entry; - Val_ref.promote_exn entry.v_ref key)) - | { target = Lazy_loaded entry } as box -> - (* In this case, [entry.v_ref] is a [Hash h] such that [mem t - (index t h) = true]. We "save" the entry in order to trigger - the [index] lookup and recover the key, in order to meet the - return invariant above. - - TODO: refactor this case to be more precise. *) - save_dirty.f entry (fun key -> - if clear then box.target <- Lazy key) - | { target = Lazy _ } -> ()) + fun { target } -> + match Atomic.get target with + | Dirty entry -> + save_dirty.f entry (fun key -> + if clear then Atomic.set target (Lazy key) + else ( + Atomic.set target (Lazy_loaded entry); + Val_ref.promote_exn entry.v_ref key)) + | Lazy_loaded entry -> + (* In this case, [entry.v_ref] is a [Hash h] such that [mem t + (index t h) = true]. We "save" the entry in order to trigger + the [index] lookup and recover the key, in order to meet the + return invariant above. + + TODO: refactor this case to be more precise. *) + save_dirty.f entry (fun key -> + if clear then Atomic.set target (Lazy key)) + | Lazy _ -> ()) | Truncated -> ( function (* TODO: this branch is currently untested: we never attempt to @@ -765,17 +769,18 @@ struct type ptr. iter_dirty:(ptr layout -> ptr t -> unit) -> ptr layout -> ptr -> unit = - fun ~iter_dirty layout ptr -> + fun ~iter_dirty layout target -> match layout with | Partial _ -> ( - match ptr with - | { target = Lazy _ } -> () - | { target = Dirty ptr } -> iter_dirty layout ptr - | { target = Lazy_loaded ptr } as box -> + let target = target.target in + match Atomic.get target with + | Lazy _ -> () + | Dirty ptr -> iter_dirty layout ptr + | Lazy_loaded ptr -> (* Since a [Lazy_loaded] used to be a [Lazy], the key is always available. *) let key = Val_ref.to_key_exn ptr.v_ref in - box.target <- Lazy key) + Atomic.set target (Lazy key)) | Total | Truncated -> () end From 37b211f42b95b8b2e4eec16774c34df08dc16e82 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Mon, 3 Jul 2023 09:13:00 +0200 Subject: [PATCH 45/99] irmin-pack: add multicore unit tests --- test/irmin-pack/dune | 1 + test/irmin-pack/test.ml | 6 +- test/irmin-pack/test_multicore.ml | 130 ++++++++++++++++++++++++++++++ test/irmin-pack/test_pack.ml | 3 +- test/irmin-pack/test_pack.mli | 2 +- 5 files changed, 138 insertions(+), 4 deletions(-) create mode 100644 test/irmin-pack/test_multicore.ml diff --git a/test/irmin-pack/dune b/test/irmin-pack/dune index dcbcd82bff..6b3f916339 100644 --- a/test/irmin-pack/dune +++ b/test/irmin-pack/dune @@ -15,6 +15,7 @@ test_flush_reload test_ranges test_mapping + test_multicore test_nearest_geq test_dispatcher test_corrupted diff --git a/test/irmin-pack/test.ml b/test/irmin-pack/test.ml index 32e5823b86..8a12515664 100644 --- a/test/irmin-pack/test.ml +++ b/test/irmin-pack/test.ml @@ -15,6 +15,8 @@ *) let () = - Eio_main.run @@ fun _env -> - Irmin_test.Store.run "irmin-pack" ~misc:Test_pack.misc ~sleep:Eio_unix.sleep + Eio_main.run @@ fun env -> + Irmin_test.Store.run "irmin-pack" + ~misc:(Test_pack.misc @@ Eio.Stdenv.domain_mgr env) + ~sleep:Eio_unix.sleep (List.map (fun s -> (`Quick, s)) Test_pack.suite) diff --git a/test/irmin-pack/test_multicore.ml b/test/irmin-pack/test_multicore.ml new file mode 100644 index 0000000000..40d0a85a37 --- /dev/null +++ b/test/irmin-pack/test_multicore.ml @@ -0,0 +1,130 @@ +(* + * Copyright (c) 2018-2023 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. + *) + +open! Import +open Common + +let root = Filename.concat "_build" "test-multicore" +let src = Logs.Src.create "tests.multicore" ~doc:"Tests" + +module Log = (val Logs.src_log src : Logs.LOG) + +module Store = struct + module Maker = Irmin_pack_unix.Maker (Conf) + include Maker.Make (Schema) + + let config ?(readonly = false) ?(fresh = true) root = + Irmin_pack.config ~readonly ?index_log_size ~fresh root +end + +module Tree = Store.Tree + +let info () = Store.Info.empty + +type shape = [ `Contents of string | `Node of (string * shape) list ] + +let shape : shape = + `Node + [ + ("a", `Contents "a"); + ("b", `Contents "b"); + ("c", `Node [ ("d", `Contents "cd"); ("e", `Contents "ce") ]); + ("f", `Node [ ("g", `Node [ ("h", `Contents "fgh") ]) ]); + ("i", `Contents "i"); + ] + +let rec flatten_shape acc path : shape -> _ = function + | `Contents c -> (List.rev path, c) :: acc + | `Node children -> + List.fold_left + (fun acc (name, child) -> flatten_shape acc (name :: path) child) + acc children + +let flatten_shape shape = flatten_shape [] [] shape + +let make_tree shape = + List.fold_left + (fun tree (k, v) -> Tree.add tree k v) + (Tree.empty ()) (flatten_shape shape) + +let make_store shape = + let repo = Store.Repo.v (Store.config ~fresh:true root) in + (* let store = Store.empty repo in *) + let main = Store.main repo in + let tree = make_tree shape in + let () = Store.set_tree_exn ~info main [] tree in + Store.Repo.close repo + +let domains_spawn d_mgr ?(nb = 2) fn = + let count = Atomic.make 0 in + let fibers = + List.init nb (fun _ () -> + Eio.Domain_manager.run d_mgr (fun () -> + Atomic.incr count; + while Atomic.get count < nb do + Domain.cpu_relax () + done; + fn ())) + in + Eio.Fiber.all fibers + +let test_find d_mgr = + Logs.set_level None; + make_store shape; + let repo = Store.Repo.v (Store.config ~readonly:true ~fresh:false root) in + let tree = Store.main repo |> Store.Head.get |> Store.Commit.tree in + let paths = flatten_shape shape in + let find_all () = + List.iter + (fun (path, expected) -> + match Store.Tree.find tree path with + | None -> assert false + | Some value -> assert (expected = value)) + paths + in + domains_spawn d_mgr find_all; + Store.Repo.close repo + +let rec expected_lengths acc path : shape -> _ = function + | `Contents _ -> (List.rev path, None) :: acc + | `Node children -> + let acc = (List.rev path, Some (List.length children)) :: acc in + List.fold_left + (fun acc (name, child) -> expected_lengths acc (name :: path) child) + acc children + +let expected_lengths shape = expected_lengths [] [] shape + +let test_length d_mgr = + Logs.set_level None; + make_store shape; + let repo = Store.Repo.v (Store.config ~readonly:true ~fresh:false root) in + let tree = Store.main repo |> Store.Head.get |> Store.Commit.tree in + let lengths = expected_lengths shape in + let find_all () = + List.iter + (fun (path, expected) -> + let value = Store.Tree.length tree path in + let value = if value = 0 then None else Some value in + assert (expected = value)) + lengths + in + domains_spawn ~nb:8 d_mgr find_all; + Store.Repo.close repo + +let tests d_mgr = + let tc name fn = Alcotest.test_case name `Quick (fun () -> fn d_mgr) in + [ tc "find" test_find; tc "length" test_length ] diff --git a/test/irmin-pack/test_pack.ml b/test/irmin-pack/test_pack.ml index e0c8d27581..595089b959 100644 --- a/test/irmin-pack/test_pack.ml +++ b/test/irmin-pack/test_pack.ml @@ -543,7 +543,7 @@ module Layout = struct ] end -let misc = +let misc d_mgr = [ ("hashes", Test_hashes.tests); ("dict-files", Dict.tests); @@ -572,4 +572,5 @@ let misc = ("indexing strategy", Test_indexing_strategy.tests); ("lower: direct", Test_lower.Direct.tests); ("lower: store", Test_lower.Store.tests); + ("multicore", Test_multicore.tests d_mgr); ] diff --git a/test/irmin-pack/test_pack.mli b/test/irmin-pack/test_pack.mli index e4a19a6027..570b975109 100644 --- a/test/irmin-pack/test_pack.mli +++ b/test/irmin-pack/test_pack.mli @@ -15,4 +15,4 @@ *) val suite : Irmin_test.Suite.t list -val misc : (string * unit Alcotest.test_case list) list +val misc : Eio.Domain_manager.t -> (string * unit Alcotest.test_case list) list From ff6e5cd038401e0adde1147b6e9a09257561fdc7 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Mon, 3 Jul 2023 09:13:38 +0200 Subject: [PATCH 46/99] Fix alcotest dependency --- irmin-containers.opam | 1 - irmin-git.opam | 2 +- irmin-graphql.opam | 3 +-- irmin-http.opam | 2 +- irmin-mirage.opam | 2 +- irmin-pack.opam | 1 - irmin-test.opam | 1 - irmin.opam | 6 ++++-- 8 files changed, 8 insertions(+), 10 deletions(-) diff --git a/irmin-containers.opam b/irmin-containers.opam index c0bb403cc4..c0f5052191 100644 --- a/irmin-containers.opam +++ b/irmin-containers.opam @@ -22,7 +22,6 @@ depends: [ "lwt" {>= "5.3.0"} "mtime" {>= "2.0.0"} "alcotest" {with-test} - "alcotest-lwt" {with-test} ] synopsis: "Mergeable Irmin data structures" diff --git a/irmin-git.opam b/irmin-git.opam index cb2df42529..9367488212 100644 --- a/irmin-git.opam +++ b/irmin-git.opam @@ -29,7 +29,7 @@ depends: [ "fpath" "logs" "lwt" {>= "5.3.0"} - "lwt_eio" {>= "0.3.0"} + "lwt_eio" {>= "0.3"} "uri" "mimic" "irmin-test" {with-test & = version} diff --git a/irmin-graphql.opam b/irmin-graphql.opam index ff2b2a9a0d..34b4a14dc4 100644 --- a/irmin-graphql.opam +++ b/irmin-graphql.opam @@ -27,8 +27,7 @@ depends: [ "git-unix" {>= "3.7.0"} "fmt" "lwt" {>= "5.3.0"} - "lwt_eio" {>= "0.3.0"} - "alcotest-lwt" {with-test & >= "1.1.0"} + "lwt_eio" {>= "0.3"} "yojson" {with-test} "alcotest" {with-test & >= "1.2.3"} "logs" {with-test} diff --git a/irmin-http.opam b/irmin-http.opam index a78a194d0f..a3ec718301 100644 --- a/irmin-http.opam +++ b/irmin-http.opam @@ -28,7 +28,7 @@ depends: [ "jsonm" "logs" "lwt" {>= "5.3.0"} - "lwt_eio" {>= "0.3.0"} + "lwt_eio" {>= "0.3"} "uri" "irmin-git" {with-test & = version} "irmin-fs" {with-test & = version} diff --git a/irmin-mirage.opam b/irmin-mirage.opam index 11dba5029c..1cb917d92e 100644 --- a/irmin-mirage.opam +++ b/irmin-mirage.opam @@ -18,7 +18,7 @@ depends: [ "fmt" "ptime" "mirage-clock" {>= "3.0.0"} - "lwt_eio" {>= "0.3.0"} + "lwt_eio" {>= "0.3"} ] synopsis: "MirageOS-compatible Irmin stores" diff --git a/irmin-pack.opam b/irmin-pack.opam index a0d7af51b8..81f2b3e092 100644 --- a/irmin-pack.opam +++ b/irmin-pack.opam @@ -27,7 +27,6 @@ depends: [ "checkseum" "rusage" "irmin-test" {with-test & = version} - "alcotest-lwt" {with-test} "astring" {with-test} "alcotest" {with-test} ] diff --git a/irmin-test.opam b/irmin-test.opam index fcadbf26c6..230a1e551a 100644 --- a/irmin-test.opam +++ b/irmin-test.opam @@ -17,7 +17,6 @@ depends: [ "ppx_irmin" {= version} "ocaml" {>= "4.02.3"} "dune" {>= "2.9.0"} - "alcotest-lwt" {>= "1.5.0"} "mtime" {>= "2.0.0"} "astring" "fmt" diff --git a/irmin.opam b/irmin.opam index 334eaf19c2..2567091534 100644 --- a/irmin.opam +++ b/irmin.opam @@ -31,9 +31,8 @@ depends: [ "bigstringaf" { >= "0.2.0" } "ppx_irmin" {= version} "hex" {with-test} - "alcotest" {>= "1.1.0" & with-test} + "alcotest" {= "dev" & with-test} "eio_main" {>= "0.2" & with-test} - "alcotest-lwt" {with-test} "qcheck-alcotest" {with-test} "vector" {with-test} "odoc" {(< "2.0.1" | > "2.0.2") & with-doc} # See https://github.com/ocaml/odoc/issues/793 @@ -44,6 +43,9 @@ pin-depends: [ # Metrics may have been unnecessarily constrained in opam-repository [ "metrics.dev" "git+https://github.com/mirage/metrics#995eb18d2837df02c8ead719c00fb156cf475ab5"] [ "metrics-unix.dev" "git+https://github.com/mirage/metrics#995eb18d2837df02c8ead719c00fb156cf475ab5"] + # Fix race in formatters + [ "alcotest.dev" "git+https://github.com/haesbaert/alcotest#99030be1df12a17fc2a0f3d00b181cd31cf6b0d4" ] + [ "alcotest-lwt.dev" "git+https://github.com/haesbaert/alcotest#99030be1df12a17fc2a0f3d00b181cd31cf6b0d4" ] ] conflicts: [ From d980b063300e220b256755913eb1427036c1d4e9 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Mon, 3 Jul 2023 10:14:37 +0200 Subject: [PATCH 47/99] Fix irmin Tree lazy length --- src/irmin/tree.ml | 57 +++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 48 insertions(+), 9 deletions(-) diff --git a/src/irmin/tree.ml b/src/irmin/tree.ml index 6eced9b7f8..4a3509da94 100644 --- a/src/irmin/tree.ml +++ b/src/irmin/tree.ml @@ -433,6 +433,41 @@ module Make (P : Backend.S) = struct | Some c -> f_value path c acc |> f_tree path) end + module Lazy_cache : sig + type 'a t + val unknown : unit -> 'a t + val make : (unit -> 'a) -> 'a t + val force : 'a t -> 'a option + val force_exn : 'a t -> 'a + val set : 'a t -> 'a -> unit + val inspect : 'a t -> 'a t option + end = struct + type 'a s = Unknown | Known of 'a | Lazy of (unit -> 'a) + type 'a t = 'a s Atomic.t + + let unknown () = Atomic.make Unknown + let make fn = Atomic.make (Lazy fn) + let force t = match Atomic.get t with + | Known v -> Some v + | Unknown -> None + | (Lazy fn) as old -> + let v = fn () in + if Atomic.compare_and_set t old (Known v) + then Some v + else match Atomic.get t with + | Known v -> Some v + | _ -> assert false + let force_exn t = match force t with + | Some v -> v + | None -> assert false + let set t v = + let _ : bool = Atomic.compare_and_set t Unknown (Known v) in + () + let inspect t = match Atomic.get t with + | Unknown -> None + | _ -> Some t + end + module Node = struct type value = P.Node.Val.t [@@deriving irmin ~equal ~pp] type key = P.Node.Key.t [@@deriving irmin] @@ -455,7 +490,7 @@ module Make (P : Backend.S) = struct mutable map : map option; mutable ptr : ptr_option; findv_cache : map option Atomic.t; - mutable length : int Lazy.t option; + length : int Lazy_cache.t; env : Env.t; } @@ -528,6 +563,10 @@ module Make (P : Backend.S) = struct in let value = Atomic.make value in let findv_cache = Atomic.make None in + let length = match length with + | None -> Lazy_cache.unknown () + | Some len -> len + in let info = { ptr; map; value; findv_cache; env; length } in { v; info } @@ -1203,11 +1242,11 @@ module Make (P : Backend.S) = struct | Pruned h -> pruned_hash_exn "length" h let length ~cache t = - match t.info.length with - | Some (lazy len) -> len + match Lazy_cache.force t.info.length with + | Some len -> len | None -> let len = slow_length ~cache t in - t.info.length <- Some (Lazy.from_val len); + Lazy_cache.set t.info.length len; len let is_empty ~cache t = @@ -1529,12 +1568,12 @@ module Make (P : Backend.S) = struct aux_uniq ~path acc 0 t Fun.id let incremental_length t step up n updates = - match t.info.length with + match Lazy_cache.inspect t.info.length with | None -> None | Some len -> Some - (lazy - (let len = Lazy.force len in + (Lazy_cache.make (fun () -> + (let len = Lazy_cache.force_exn len in let exists = match StepMap.find_opt step updates with | Some (Add _) -> true @@ -1547,7 +1586,7 @@ module Make (P : Backend.S) = struct match up with | Add _ when not exists -> len + 1 | Remove when exists -> len - 1 - | _ -> len)) + | _ -> len))) let update t step up = let env = t.info.env in @@ -1704,7 +1743,7 @@ module Make (P : Backend.S) = struct let of_backend_node repo n = let env = Env.empty () in - let length = lazy (P.Node.Val.length n) in + let length = Lazy_cache.make (fun () -> P.Node.Val.length n) in Node.of_value ~length ~env repo n let dump ppf = function From 55dcad5b04a85f0c36d80756202919090837e673 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Mon, 3 Jul 2023 10:21:02 +0200 Subject: [PATCH 48/99] Fix irmin Tree Contents mutables --- src/irmin/tree.ml | 48 ++++++++++++++++++++++++----------------------- 1 file changed, 25 insertions(+), 23 deletions(-) diff --git a/src/irmin/tree.ml b/src/irmin/tree.ml index 4a3509da94..648d5dd17c 100644 --- a/src/irmin/tree.ml +++ b/src/irmin/tree.ml @@ -262,14 +262,14 @@ module Make (P : Backend.S) = struct type nonrec ptr_option = key ptr_option type info = { - mutable ptr : ptr_option; - mutable value : contents option; + ptr : ptr_option Atomic.t; + value : contents option Atomic.t; env : Env.t; } - type t = { mutable v : v; info : info } + type t = { v : v Atomic.t; info : info } - let info_is_empty i = i.ptr = Ptr_none && i.value = None + let info_is_empty i = Atomic.get i.ptr = Ptr_none && Atomic.get i.value = None let v = let open Type in @@ -285,8 +285,8 @@ module Make (P : Backend.S) = struct let clear_info i = if not (info_is_empty i) then ( - i.value <- None; - i.ptr <- Ptr_none) + Atomic.set i.value None; + Atomic.set i.ptr Ptr_none) let clear t = clear_info t.info @@ -297,18 +297,20 @@ module Make (P : Backend.S) = struct | Value v -> (Ptr_none, Some v) | Pruned _ -> (Ptr_none, None) in + let ptr = Atomic.make ptr in + let value = Atomic.make value in let info = { ptr; value; env } in - { v; info } + { v = Atomic.make v; info } let export ?clear:(c = true) repo t k = - let ptr = t.info.ptr in + let ptr = Atomic.get t.info.ptr in if c then clear t; - match (t.v, ptr) with + match (Atomic.get t.v, ptr) with | Key (repo', _), (Ptr_none | Hash _) -> - if repo != repo' then t.v <- Key (repo, k) - | Key (repo', _), Key k -> if repo != repo' then t.v <- Key (repo, k) - | Value _, (Ptr_none | Hash _) -> t.v <- Key (repo, k) - | Value _, Key k -> t.v <- Key (repo, k) + if repo != repo' then Atomic.set t.v (Key (repo, k)) + | Key (repo', _), Key k -> if repo != repo' then Atomic.set t.v (Key (repo, k)) + | Value _, (Ptr_none | Hash _) -> Atomic.set t.v (Key (repo, k)) + | Value _, Key k -> Atomic.set t.v (Key (repo, k)) | Pruned _, _ -> (* The main export function never exports a pruned position. *) assert false @@ -318,7 +320,7 @@ module Make (P : Backend.S) = struct let pruned h = of_v (Pruned h) let cached_hash t = - match (t.v, t.info.ptr) with + match (Atomic.get t.v, Atomic.get t.info.ptr) with | Key (_, k), _ -> Some (P.Contents.Key.to_hash k) | Value _, Key k -> Some (P.Contents.Key.to_hash k) | Pruned h, _ -> Some h @@ -326,13 +328,13 @@ module Make (P : Backend.S) = struct | Value _, Ptr_none -> None let cached_key t = - match (t.v, t.info.ptr) with + match (Atomic.get t.v, Atomic.get t.info.ptr) with | Key (_, k), _ -> Some k | (Value _ | Pruned _), Key k -> Some k | (Value _ | Pruned _), (Hash _ | Ptr_none) -> None let cached_value t = - match (t.v, t.info.value) with + match (Atomic.get t.v, Atomic.get t.info.value) with | Value v, None -> Some v | (Key _ | Value _ | Pruned _), (Some _ as v) -> v | (Key _ | Pruned _), None -> ( @@ -352,12 +354,12 @@ module Make (P : Backend.S) = struct | Some v -> Atomic.incr cnt.contents_hash; let h = P.Contents.Hash.hash v in - assert (c.info.ptr = Ptr_none); - if cache then c.info.ptr <- Hash h; + assert (Atomic.get c.info.ptr = Ptr_none); + if cache then Atomic.set c.info.ptr (Hash h); h) let key t = - match t.v with Key (_, k) -> Some k | Value _ | Pruned _ -> None + match Atomic.get t.v with Key (_, k) -> Some k | Value _ | Pruned _ -> None let value_of_key ~cache t repo k = Atomic.incr cnt.contents_find; @@ -367,14 +369,14 @@ module Make (P : Backend.S) = struct match v_opt with | None -> err_dangling_hash h | Some v -> - if cache then t.info.value <- v_opt; + if cache then Atomic.set t.info.value v_opt; Ok v let to_value ~cache t = match cached_value t with | Some v -> ok v | None -> ( - match t.v with + match Atomic.get t.v with | Value _ -> assert false (* [cached_value == None] *) | Key (repo, k) -> value_of_key ~cache t repo k | Pruned h -> err_pruned_hash h) @@ -401,7 +403,7 @@ module Make (P : Backend.S) = struct let t = let of_v v = of_v ~env:(Env.empty ()) v in - Type.map ~equal ~compare v of_v (fun t -> t.v) + Type.map ~equal ~compare v of_v (fun t -> Atomic.get t.v) let merge : t Merge.t = let f ~old x y = @@ -2300,7 +2302,7 @@ module Make (P : Backend.S) = struct [ `Contents of Contents.t * metadata ] -> ([ `Content_exported ], r) cont_lwt = fun (`Contents (c, _)) k -> - match c.Contents.v with + match Atomic.get c.Contents.v with | Contents.Key (_, key) -> Contents.export ?clear repo c key; k `Content_exported From 3607a5824eb157323a462153e7215dc9649ed8c3 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Mon, 3 Jul 2023 11:11:29 +0200 Subject: [PATCH 49/99] Fix irmin proof --- src/irmin/proof.ml | 69 +++++++++++++++++++++++++++-------------- src/irmin/proof_intf.ml | 8 ++--- src/irmin/store.ml | 1 - src/irmin/store_intf.ml | 7 ++--- src/irmin/tree_intf.ml | 9 ++---- 5 files changed, 52 insertions(+), 42 deletions(-) diff --git a/src/irmin/proof.ml b/src/irmin/proof.ml index a25319cafa..1bcdbd89df 100644 --- a/src/irmin/proof.ml +++ b/src/irmin/proof.ml @@ -87,15 +87,36 @@ struct module H = B.Hash module Hashes = struct - include Hashtbl.Make (struct + module Unsafe = Hashtbl.Make (struct type t = H.t let hash = H.short_hash let equal = Type.(unstage (equal H.t)) end) + type 'a t = { lock : Eio.Mutex.t; data : 'a Unsafe.t } + + let of_unsafe data = { lock = Eio.Mutex.create (); data } + let create size = of_unsafe (Unsafe.create size) + + let mem { lock; data } k = + Eio.Mutex.use_ro lock @@ fun () -> Unsafe.mem data k + + let find_opt { lock; data } k = + Eio.Mutex.use_ro lock @@ fun () -> Unsafe.find_opt data k + + let add { lock; data } k v = + Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.add data k v + + let replace { lock; data } k v = + Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.replace data k v + + let of_seq s = of_unsafe (Unsafe.of_seq s) let of_list l = of_seq (List.to_seq l) - let to_list t = List.of_seq (to_seq t) + + let to_list t = + Eio.Mutex.use_ro t.lock @@ fun () -> List.of_seq (Unsafe.to_seq t.data) + let t elt_t = Type.map [%typ: (H.t * elt) list] of_list to_list end @@ -129,43 +150,45 @@ struct end type v = Empty | Set of Set.t [@@deriving irmin] - type t = v ref + type t = v Atomic.t - let t = Type.map v_t ref ( ! ) - let empty () : t = ref Empty - let is_empty t = !t = Empty - let copy ~into t = into := !t + let t = Type.map v_t Atomic.make Atomic.get + let empty () : t = Atomic.make Empty + let is_empty t = Atomic.get t = Empty + let copy ~into t = Atomic.set into (Atomic.get t) type hash = H.t [@@deriving irmin ~equal ~pp] let set_mode t mode = - match (!t, mode) with - | Empty, Produce -> t := Set Set.(producer ()) - | Empty, Deserialise -> t := Set Set.(deserialiser ()) - | Set (Produce set), Serialise -> t := Set Set.(Serialise set) - | Set (Deserialise set), Consume -> t := Set Set.(Consume set) + Atomic.set t + @@ + match (Atomic.get t, mode) with + | Empty, Produce -> Set Set.(producer ()) + | Empty, Deserialise -> Set Set.(deserialiser ()) + | Set (Produce set), Serialise -> Set Set.(Serialise set) + | Set (Deserialise set), Consume -> Set Set.(Consume set) | _ -> assert false let with_consume f = - let t = ref Empty in + let t = Atomic.make Empty in set_mode t Deserialise; let stop_deserialise () = set_mode t Consume in let res = f t ~stop_deserialise in - t := Empty; + Atomic.set t Empty; res let with_produce f = - let t = ref Empty in + let t = Atomic.make Empty in set_mode t Produce; let start_serialise () = set_mode t Serialise in let res = f t ~start_serialise in - t := Empty; + Atomic.set t Empty; res module Contents_hash = Hash.Typed (H) (B.Contents.Val) let find_contents t h = - match !t with + match Atomic.get t with | Empty -> None | Set (Produce set) -> (* Sharing of contents is not strictly needed during this phase. It @@ -183,7 +206,7 @@ struct Hashes.find_opt set.contents h let add_contents_from_store t h v = - match !t with + match Atomic.get t with | Empty -> () | Set (Produce set) -> (* Registering in [set] for traversal during [Serialise]. *) @@ -200,7 +223,7 @@ struct assert false let add_contents_from_proof t h v = - match !t with + match Atomic.get t with | Set (Deserialise set) -> (* Using [replace] because there could be several instances of this contents in the proof, we will not share as this is not strictly @@ -212,7 +235,7 @@ struct | _ -> assert false let find_node t h = - match !t with + match Atomic.get t with | Empty -> None | Set (Produce set) -> (* This is needed in order to achieve sharing on inode's pointers. In @@ -232,7 +255,7 @@ struct None let find_pnode t h = - match !t with + match Atomic.get t with | Set (Consume set) -> (* [set] has been filled during deserialise. Using it to provide values during consume. *) @@ -240,7 +263,7 @@ struct | _ -> None let add_node_from_store t h v = - match !t with + match Atomic.get t with | Empty -> v | Set (Produce set) -> (* Registering in [set] for sharing during [Produce] and traversal @@ -260,7 +283,7 @@ struct assert false let add_pnode_from_proof t h v = - match !t with + match Atomic.get t with | Set (Deserialise set) -> (* Using [replace] because there could be several instances of this node in the proof, we will not share as this is not strictly diff --git a/src/irmin/proof_intf.ml b/src/irmin/proof_intf.ml index 86ce26ccfa..07f225401e 100644 --- a/src/irmin/proof_intf.ml +++ b/src/irmin/proof_intf.ml @@ -219,12 +219,8 @@ module type Env = sig (** {2 Modes} *) val set_mode : t -> mode -> unit - - val with_produce : - (t -> start_serialise:(unit -> unit) -> 'a) -> 'a - - val with_consume : - (t -> stop_deserialise:(unit -> unit) -> 'a) -> 'a + val with_produce : (t -> start_serialise:(unit -> unit) -> 'a) -> 'a + val with_consume : (t -> stop_deserialise:(unit -> unit) -> 'a) -> 'a (** {2 Interactions With [Tree]} *) diff --git a/src/irmin/store.ml b/src/irmin/store.ml index f3507c286d..b54603cbb5 100644 --- a/src/irmin/store.ml +++ b/src/irmin/store.ml @@ -1188,7 +1188,6 @@ module Make (B : Backend.S) = struct Fmt.kstr invalid_arg "Branch.get: %a not found" pp_branch k let get t k = match find t k with None -> err_not_found k | Some v -> v - let pp = pp_branch end diff --git a/src/irmin/store_intf.ml b/src/irmin/store_intf.ml index 3f710d1462..6caed2380f 100644 --- a/src/irmin/store_intf.ml +++ b/src/irmin/store_intf.ml @@ -480,10 +480,7 @@ module type S_generic_key = sig (** {1 Proofs} *) type 'result producer := - repo -> - kinded_key -> - (tree -> (tree * 'result)) -> - (Proof.t * 'result) + repo -> kinded_key -> (tree -> tree * 'result) -> Proof.t * 'result (** [produce r h f] runs [f] on top of a real store [r], producing a proof and a result using the initial root hash [h]. @@ -498,7 +495,7 @@ module type S_generic_key = sig type 'result verifier := Proof.t -> - (tree -> (tree * 'result)) -> + (tree -> tree * 'result) -> (tree * 'result, verifier_error) result (** [verify p f] runs [f] in checking mode. [f] is a function that takes a tree as input and returns a new version of the tree and a result. [p] is diff --git a/src/irmin/tree_intf.ml b/src/irmin/tree_intf.ml index cb5004af61..fd4f946fc8 100644 --- a/src/irmin/tree_intf.ml +++ b/src/irmin/tree_intf.ml @@ -461,17 +461,12 @@ module type Sigs = sig val of_backend_node : B.Repo.t -> B.Node.value -> node type 'result producer := - B.Repo.t -> - kinded_key -> - (t -> (t * 'result)) -> - (Proof.t * 'result) + B.Repo.t -> kinded_key -> (t -> t * 'result) -> Proof.t * 'result type verifier_error = [ `Proof_mismatch of string ] [@@deriving irmin] type 'result verifier := - Proof.t -> - (t -> (t * 'result)) -> - (t * 'result, verifier_error) result + Proof.t -> (t -> t * 'result) -> (t * 'result, verifier_error) result val produce_proof : 'a producer val verify_proof : 'a verifier From bbaf30b150b26a6a1598a041fdea09b30b656607 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Mon, 3 Jul 2023 11:41:25 +0200 Subject: [PATCH 50/99] Fix irmin Tree add and remove --- src/irmin/tree.ml | 144 ++++++++++++++++-------------- test/irmin-pack/test_multicore.ml | 121 +++++++++++++++++++++---- 2 files changed, 179 insertions(+), 86 deletions(-) diff --git a/src/irmin/tree.ml b/src/irmin/tree.ml index 648d5dd17c..2e324bb284 100644 --- a/src/irmin/tree.ml +++ b/src/irmin/tree.ml @@ -269,7 +269,8 @@ module Make (P : Backend.S) = struct type t = { v : v Atomic.t; info : info } - let info_is_empty i = Atomic.get i.ptr = Ptr_none && Atomic.get i.value = None + let info_is_empty i = + Atomic.get i.ptr = Ptr_none && Atomic.get i.value = None let v = let open Type in @@ -308,7 +309,8 @@ module Make (P : Backend.S) = struct match (Atomic.get t.v, ptr) with | Key (repo', _), (Ptr_none | Hash _) -> if repo != repo' then Atomic.set t.v (Key (repo, k)) - | Key (repo', _), Key k -> if repo != repo' then Atomic.set t.v (Key (repo, k)) + | Key (repo', _), Key k -> + if repo != repo' then Atomic.set t.v (Key (repo, k)) | Value _, (Ptr_none | Hash _) -> Atomic.set t.v (Key (repo, k)) | Value _, Key k -> Atomic.set t.v (Key (repo, k)) | Pruned _, _ -> @@ -359,7 +361,9 @@ module Make (P : Backend.S) = struct h) let key t = - match Atomic.get t.v with Key (_, k) -> Some k | Value _ | Pruned _ -> None + match Atomic.get t.v with + | Key (_, k) -> Some k + | Value _ | Pruned _ -> None let value_of_key ~cache t repo k = Atomic.incr cnt.contents_find; @@ -437,6 +441,7 @@ module Make (P : Backend.S) = struct module Lazy_cache : sig type 'a t + val unknown : unit -> 'a t val make : (unit -> 'a) -> 'a t val force : 'a t -> 'a option @@ -449,25 +454,23 @@ module Make (P : Backend.S) = struct let unknown () = Atomic.make Unknown let make fn = Atomic.make (Lazy fn) - let force t = match Atomic.get t with + + let force t = + match Atomic.get t with | Known v -> Some v | Unknown -> None - | (Lazy fn) as old -> + | Lazy fn as old -> ( let v = fn () in - if Atomic.compare_and_set t old (Known v) - then Some v - else match Atomic.get t with - | Known v -> Some v - | _ -> assert false - let force_exn t = match force t with - | Some v -> v - | None -> assert false + if Atomic.compare_and_set t old (Known v) then Some v + else match Atomic.get t with Known v -> Some v | _ -> assert false) + + let force_exn t = match force t with Some v -> v | None -> assert false + let set t v = - let _ : bool = Atomic.compare_and_set t Unknown (Known v) in + let (_ : bool) = Atomic.compare_and_set t Unknown (Known v) in () - let inspect t = match Atomic.get t with - | Unknown -> None - | _ -> Some t + + let inspect t = match Atomic.get t with Unknown -> None | _ -> Some t end module Node = struct @@ -489,8 +492,8 @@ module Make (P : Backend.S) = struct and info = { value : value option Atomic.t; - mutable map : map option; - mutable ptr : ptr_option; + map : map option Atomic.t; + ptr : ptr_option Atomic.t; findv_cache : map option Atomic.t; length : int Lazy_cache.t; env : Env.t; @@ -503,7 +506,7 @@ module Make (P : Backend.S) = struct | Portable_dirty of portable * updatemap | Pruned of hash - and t = { mutable v : v; info : info } + and t = { v : v Atomic.t; info : info } (** For discussion of [t.v]'s states, see {!Tree_intf.S.inspect}. [t.info.map] is only populated during a call to [Node.to_map]. *) @@ -563,13 +566,15 @@ module Make (P : Backend.S) = struct | Value (_, v, None) -> (Ptr_none, None, Some v) | Value _ | Portable_dirty _ | Pruned _ -> (Ptr_none, None, None) in + let ptr = Atomic.make ptr in + let map = Atomic.make map in let value = Atomic.make value in let findv_cache = Atomic.make None in - let length = match length with - | None -> Lazy_cache.unknown () - | Some len -> len + let length = + match length with None -> Lazy_cache.unknown () | Some len -> len in let info = { ptr; map; value; findv_cache; env; length } in + let v = Atomic.make v in { v; info } let of_map m = of_v (Map m) @@ -582,10 +587,10 @@ module Make (P : Backend.S) = struct let pruned h = of_v (Pruned h) let info_is_empty i = - i.map = None + Atomic.get i.map = None && Atomic.get i.value = None && Atomic.get i.findv_cache = None - && i.ptr = Ptr_none + && Atomic.get i.ptr = Ptr_none let rec add_to_findv_cache t step v = let old_value = Atomic.get t.info.findv_cache in @@ -600,8 +605,8 @@ module Make (P : Backend.S) = struct let clear_info_fields i = if not (info_is_empty i) then ( Atomic.set i.value None; - i.map <- None; - i.ptr <- Ptr_none; + Atomic.set i.map None; + Atomic.set i.ptr Ptr_none; Atomic.set i.findv_cache None) let rec clear_elt ~max_depth depth v = @@ -620,7 +625,7 @@ module Make (P : Backend.S) = struct | Value (_, _, None) | Map _ | Key _ | Portable_dirty _ | Pruned _ -> () in let () = - match (v, i.map) with + match (v, Atomic.get i.map) with | Map m, _ | (Key _ | Value _ | Portable_dirty _ | Pruned _), Some m -> StepMap.iter clear m | (Key _ | Value _ | Portable_dirty _ | Pruned _), None -> () @@ -632,18 +637,19 @@ module Make (P : Backend.S) = struct in if depth >= max_depth then clear_info_fields i - and clear ~max_depth depth t = clear_info ~v:t.v ~max_depth depth t.info + and clear ~max_depth depth t = + clear_info ~v:(Atomic.get t.v) ~max_depth depth t.info (* export t to the given repo and clear the cache *) let export ?clear:(c = true) repo t k = let ptr = t.info.ptr in if c then clear_info_fields t.info; - match t.v with - | Key (repo', k) -> if repo != repo' then t.v <- Key (repo, k) + match Atomic.get t.v with + | Key (repo', k) -> if repo != repo' then Atomic.set t.v (Key (repo, k)) | Value _ | Map _ -> ( - match ptr with - | Ptr_none | Hash _ -> t.v <- Key (repo, k) - | Key k -> t.v <- Key (repo, k)) + match Atomic.get ptr with + | Ptr_none | Hash _ -> Atomic.set t.v (Key (repo, k)) + | Key k -> Atomic.set t.v (Key (repo, k))) | Portable_dirty _ | Pruned _ -> (* The main export function never exports a pruned position. *) assert false @@ -729,7 +735,7 @@ module Make (P : Backend.S) = struct [t.info], looking for specific patterns. *) module Scan = struct let iter_hash t hit miss miss_arg = - match (t.v, t.info.ptr) with + match (Atomic.get t.v, Atomic.get t.info.ptr) with | Key (_, k), _ -> hit (P.Node.Key.to_hash k) | (Map _ | Value _ | Portable_dirty _), Key k -> hit (P.Node.Key.to_hash k) @@ -738,7 +744,7 @@ module Make (P : Backend.S) = struct | (Map _ | Value _ | Portable_dirty _), Ptr_none -> miss t miss_arg let iter_key t hit miss miss_arg = - match (t.v, t.info.ptr) with + match (Atomic.get t.v, Atomic.get t.info.ptr) with | Key (_, k), _ -> hit k | (Map _ | Value _ | Portable_dirty _ | Pruned _), Key k -> hit k | (Map _ | Value _ | Portable_dirty _ | Pruned _), (Hash _ | Ptr_none) @@ -746,14 +752,14 @@ module Make (P : Backend.S) = struct miss t miss_arg let iter_map t hit miss miss_arg = - match (t.v, t.info.map) with + match (Atomic.get t.v, Atomic.get t.info.map) with | (Key _ | Value _ | Portable_dirty _ | Pruned _), Some m -> hit m | Map m, _ -> hit m | (Key _ | Value _ | Portable_dirty _ | Pruned _), None -> miss t miss_arg let iter_value t hit miss miss_arg = - match (t.v, Atomic.get t.info.value) with + match (Atomic.get t.v, Atomic.get t.info.value) with | Value (_, v, None), None -> hit v | (Map _ | Key _ | Value _ | Portable_dirty _ | Pruned _), Some v -> hit v @@ -768,7 +774,7 @@ module Make (P : Backend.S) = struct miss miss_arg let iter_portable t hit miss miss_arg = - match t.v with + match Atomic.get t.v with | Pruned h -> ( match Env.find_pnode t.info.env h with | None -> miss t miss_arg @@ -779,13 +785,13 @@ module Make (P : Backend.S) = struct miss t miss_arg let iter_repo_key t hit miss miss_arg = - match (t.v, t.info.ptr) with + match (Atomic.get t.v, Atomic.get t.info.ptr) with | Key (repo, k), _ -> hit repo k | Value (repo, _, _), Key k -> hit repo k | (Map _ | Portable_dirty _ | Pruned _ | Value _), _ -> miss t miss_arg let iter_repo_value t hit miss miss_arg = - match (t.v, Atomic.get t.info.value) with + match (Atomic.get t.v, Atomic.get t.info.value) with | Value (repo, v, None), _ -> hit repo v | (Value (repo, _, _) | Key (repo, _)), Some v -> hit repo v | (Value (repo, _, _) | Key (repo, _)), None -> @@ -845,18 +851,18 @@ module Make (P : Backend.S) = struct let to_portable t miss = iter_portable t (fun v -> Portable v) miss let to_value_dirty t miss miss_arg = - match t.v with + match Atomic.get t.v with | Value (repo, v, Some um) -> Value_dirty (repo, v, um) | Map _ | Key _ | Value (_, _, None) | Portable_dirty _ | Pruned _ -> miss t miss_arg let to_portable_dirty t miss miss_arg = - match t.v with + match Atomic.get t.v with | Portable_dirty (v, um) -> Portable_dirty (v, um) | Map _ | Key _ | Value _ | Pruned _ -> miss t miss_arg let to_pruned t miss miss_arg = - match t.v with + match Atomic.get t.v with | Pruned h -> Pruned h | Map _ | Key _ | Value _ | Portable_dirty _ -> miss t miss_arg @@ -893,7 +899,7 @@ module Make (P : Backend.S) = struct let cached_portable t = Scan.iter_portable t Option.some get_none () let key t = - match t.v with + match Atomic.get t.v with | Key (_, k) -> Some k | Map _ | Value _ | Portable_dirty _ | Pruned _ -> None @@ -920,8 +926,8 @@ module Make (P : Backend.S) = struct let a_of_hashable hash v = Atomic.incr cnt.node_hash; let hash = hash v in - assert (t.info.ptr = Ptr_none); - if cache then t.info.ptr <- Hash hash; + assert (Atomic.get t.info.ptr = Ptr_none); + if cache then Atomic.set t.info.ptr (Hash hash); k hash in match @@ -1059,7 +1065,7 @@ module Make (P : Backend.S) = struct | Value v -> ok v | Repo_key (repo, k) -> value_of_key ~cache t repo k | Any -> ( - match t.v with + match Atomic.get t.v with | Key _ | Value (_, _, None) -> assert false | Pruned h -> err_pruned_hash h | Portable_dirty _ -> err_portable_value @@ -1121,7 +1127,7 @@ module Make (P : Backend.S) = struct | _, Some Remove -> None) m updates in - if cache then t.info.map <- Some m; + if cache then Atomic.set t.info.map (Some m); m in let of_value repo v um = @@ -1575,20 +1581,20 @@ module Make (P : Backend.S) = struct | Some len -> Some (Lazy_cache.make (fun () -> - (let len = Lazy_cache.force_exn len in - let exists = - match StepMap.find_opt step updates with - | Some (Add _) -> true - | Some Remove -> false - | None -> ( - match P.Node.Val.find n step with - | None -> false - | Some _ -> true) - in - match up with - | Add _ when not exists -> len + 1 - | Remove when exists -> len - 1 - | _ -> len))) + let len = Lazy_cache.force_exn len in + let exists = + match StepMap.find_opt step updates with + | Some (Add _) -> true + | Some Remove -> false + | None -> ( + match P.Node.Val.find n step with + | None -> false + | Some _ -> true) + in + match up with + | Add _ when not exists -> len + 1 + | Remove when exists -> len - 1 + | _ -> len)) let update t step up = let env = t.info.env in @@ -1650,7 +1656,7 @@ module Make (P : Backend.S) = struct let t node = let of_v v = of_v ~env:(Env.empty ()) v in - Type.map ~equal ~compare node of_v (fun t -> t.v) + Type.map ~equal ~compare node of_v (fun t -> Atomic.get t.v) let _, t = Type.mu2 (fun _ y -> @@ -2190,7 +2196,7 @@ module Make (P : Backend.S) = struct k key in let has_repo = - match n.Node.v with + match Atomic.get n.Node.v with | Node.Key (repo', _) -> if same_repo repo repo' then true else @@ -2208,7 +2214,7 @@ module Make (P : Backend.S) = struct failwith "Can't export a node value from another repo" | Pruned _ | Portable_dirty _ | Map _ -> false in - match n.Node.v with + match Atomic.get n.Node.v with | Pruned h -> (* Case 3. [n] is a pruned hash. [P.Node.index node_t h] could be different than [None], but let's always crash. *) @@ -2273,7 +2279,7 @@ module Make (P : Backend.S) = struct Case 9. Let's export it to the backend. *) let new_children_seq = let seq = - match n.Node.v with + match Atomic.get n.Node.v with | Value (_, _, Some m) -> StepMap.to_seq m |> Seq.filter_map (function @@ -2289,7 +2295,7 @@ module Make (P : Backend.S) = struct Seq.map (fun (_, x) -> x) seq in on_node_seq new_children_seq @@ fun `Node_children_exported -> - match (n.Node.v, Node.cached_value n) with + match (Atomic.get n.Node.v, Node.cached_value n) with | Map x, _ -> add_node_map n x k | Value (_, v, None), None | _, Some v -> add_node n v k | Value (_, v, Some um), _ -> add_updated_node n v um k @@ -2584,7 +2590,7 @@ module Make (P : Backend.S) = struct | `Contents _ -> `Contents | `Node n -> `Node - (match n.Node.v with + (match Atomic.get n.Node.v with | Map _ -> `Map | Value _ -> `Value | Key _ -> `Key diff --git a/test/irmin-pack/test_multicore.ml b/test/irmin-pack/test_multicore.ml index 40d0a85a37..60c5e1b632 100644 --- a/test/irmin-pack/test_multicore.ml +++ b/test/irmin-pack/test_multicore.ml @@ -36,7 +36,7 @@ let info () = Store.Info.empty type shape = [ `Contents of string | `Node of (string * shape) list ] -let shape : shape = +let shape0 : shape = `Node [ ("a", `Contents "a"); @@ -46,6 +46,25 @@ let shape : shape = ("i", `Contents "i"); ] +let shape1 : shape = + `Node + [ + ("a", `Contents "a"); + ("b", `Contents "b"); + ( "c", + `Node + [ + ("d", `Contents "cd"); + ("e", `Contents "ce"); + ("c_new", `Node [ ("c_new_new", `Contents "c_new_new") ]); + ] ); + ("f", `Node [ ("g", `Node [ ("h", `Contents "fgh") ]) ]); + ("i", `Contents "i"); + ("new", `Contents "new"); + ( "new_new", + `Node [ ("a", `Contents "new_new_a"); ("b", `Contents "new_new_b") ] ); + ] + let rec flatten_shape acc path : shape -> _ = function | `Contents c -> (List.rev path, c) :: acc | `Node children -> @@ -81,21 +100,21 @@ let domains_spawn d_mgr ?(nb = 2) fn = in Eio.Fiber.all fibers +let find_all tree paths = + List.iter + (fun (path, expected) -> + match Store.Tree.find tree path with + | None -> assert false + | Some value -> assert (expected = value)) + paths + let test_find d_mgr = Logs.set_level None; - make_store shape; + make_store shape0; let repo = Store.Repo.v (Store.config ~readonly:true ~fresh:false root) in let tree = Store.main repo |> Store.Head.get |> Store.Commit.tree in - let paths = flatten_shape shape in - let find_all () = - List.iter - (fun (path, expected) -> - match Store.Tree.find tree path with - | None -> assert false - | Some value -> assert (expected = value)) - paths - in - domains_spawn d_mgr find_all; + let paths = flatten_shape shape0 in + domains_spawn d_mgr (fun () -> find_all tree paths); Store.Repo.close repo let rec expected_lengths acc path : shape -> _ = function @@ -110,11 +129,11 @@ let expected_lengths shape = expected_lengths [] [] shape let test_length d_mgr = Logs.set_level None; - make_store shape; + make_store shape0; let repo = Store.Repo.v (Store.config ~readonly:true ~fresh:false root) in let tree = Store.main repo |> Store.Head.get |> Store.Commit.tree in - let lengths = expected_lengths shape in - let find_all () = + let lengths = expected_lengths shape0 in + let all_length () = List.iter (fun (path, expected) -> let value = Store.Tree.length tree path in @@ -122,9 +141,77 @@ let test_length d_mgr = assert (expected = value)) lengths in - domains_spawn ~nb:8 d_mgr find_all; + domains_spawn ~nb:2 d_mgr all_length; + Store.Repo.close repo + +let rec remove_all acc path : shape -> _ = function + | `Contents _ -> [ `Remove (List.rev path) ] + | `Node children -> + List.fold_left + (fun acc (name, child) -> remove_all acc (name :: path) child) + acc children + +let rec diff_shape acc path (old_shape : shape option) (new_shape : shape) = + match (old_shape, new_shape) with + | Some (`Contents old), `Contents new_ when old = new_ -> acc + | _, `Contents new_ -> `Add (List.rev path, new_) :: acc + | _, `Node new_children -> + let old_children = + match old_shape with + | None -> [] + | Some (`Node old_children) -> old_children + | _ -> assert false + in + let acc = + List.fold_left + (fun acc (old_name, old_child) -> + match List.assoc_opt old_name new_children with + | None -> remove_all acc (old_name :: path) old_child + | Some _ -> acc) + acc old_children + in + List.fold_left + (fun acc (name, new_child) -> + let old_child = List.assoc_opt name old_children in + diff_shape acc (name :: path) old_child new_child) + acc new_children + +let diff_shape old_shape new_shape = + List.rev @@ diff_shape [] [] (Some old_shape) new_shape + +let test_add_remove d_mgr = + Logs.set_level None; + make_store shape0; + let repo = Store.Repo.v (Store.config ~readonly:true ~fresh:false root) in + let tree = Store.main repo |> Store.Head.get |> Store.Commit.tree in + let patch = diff_shape shape0 shape1 in + let after_paths = flatten_shape shape1 in + let add_all () = + let tree = + List.fold_left + (fun tree -> function + | `Add (path, contents) -> + Format.printf "[%i] add %s@." + (Domain.self () :> int) + (String.concat ";" path); + Tree.add tree path contents + | `Remove path -> Tree.remove tree path) + tree patch + in + find_all tree after_paths; + List.iter + (function + | `Add (name, _) -> assert (Tree.mem tree name) + | `Remove name -> assert (not (Tree.mem tree name))) + patch + in + domains_spawn ~nb:2 d_mgr add_all; Store.Repo.close repo let tests d_mgr = let tc name fn = Alcotest.test_case name `Quick (fun () -> fn d_mgr) in - [ tc "find" test_find; tc "length" test_length ] + [ + tc "find" test_find; + tc "length" test_length; + tc "add / remove" test_add_remove; + ] From c3cf319262f0354e0bdbf7b2847b7e4ff65ab10a Mon Sep 17 00:00:00 2001 From: ArthurW Date: Mon, 3 Jul 2023 13:13:26 +0200 Subject: [PATCH 51/99] Fix irmin-pack Append_only_file buffer length --- src/irmin-pack/unix/append_only_file.ml | 54 ++++++++++++++++--------- 1 file changed, 36 insertions(+), 18 deletions(-) diff --git a/src/irmin-pack/unix/append_only_file.ml b/src/irmin-pack/unix/append_only_file.ml index 36e7fef526..b41cd29bca 100644 --- a/src/irmin-pack/unix/append_only_file.ml +++ b/src/irmin-pack/unix/append_only_file.ml @@ -23,22 +23,34 @@ module Make (Io : Io.S) (Errs : Io_errors.S with module Io = Io) = struct let auto_flush_threshold = 16_384 - type rw_perm = { buf : Buffer.t; mutable fsync_required : bool } + type rw_perm = { + fsync_required : bool Atomic.t; + buf : Buffer.t; + buf_length : int Atomic.t; + } (** [rw_perm] contains the data necessary to operate in readwrite mode. *) type t = { io : Io.t; - mutable persisted_end_poff : int63; + persisted_end_poff : int63 Atomic.t; dead_header_size : int63; rw_perm : rw_perm option; } - let create_rw_perm () = Some { buf = Buffer.create 0; fsync_required = false } + let create_rw_perm () = + Some + { + fsync_required = Atomic.make false; + buf = Buffer.create 0; + buf_length = Atomic.make 0; + } let create_rw ~path ~overwrite = let open Result_syntax in let+ io = Io.create ~path ~overwrite in - let persisted_end_poff = Int63.zero in + let persisted_end_poff = Atomic.make Int63.zero in + let buf = Buffer.create 0 in + let buf_length = Atomic.make 0 in { io; persisted_end_poff; @@ -76,7 +88,7 @@ module Make (Io : Io.S) (Errs : Io_errors.S with module Io = Io) = struct let open Result_syntax in let* io = Io.open_ ~path ~readonly:false in let+ () = check_consistent_store ~end_poff ~dead_header_size io in - let persisted_end_poff = end_poff in + let persisted_end_poff = Atomic.make end_poff in let dead_header_size = Int63.of_int dead_header_size in { io; persisted_end_poff; dead_header_size; rw_perm = create_rw_perm () } @@ -84,7 +96,7 @@ module Make (Io : Io.S) (Errs : Io_errors.S with module Io = Io) = struct let open Result_syntax in let* io = Io.open_ ~path ~readonly:true in let+ () = check_consistent_store ~end_poff ~dead_header_size io in - let persisted_end_poff = end_poff in + let persisted_end_poff = Atomic.make end_poff in let dead_header_size = Int63.of_int dead_header_size in { io; persisted_end_poff; dead_header_size; rw_perm = None } @@ -99,17 +111,18 @@ module Make (Io : Io.S) (Errs : Io_errors.S with module Io = Io) = struct let path t = Io.path t.io let end_poff t = + let persisted_end_poff = Atomic.get t.persisted_end_poff in match t.rw_perm with - | None -> t.persisted_end_poff + | None -> persisted_end_poff | Some rw_perm -> let open Int63.Syntax in - t.persisted_end_poff + (Buffer.length rw_perm.buf |> Int63.of_int) + persisted_end_poff + (Atomic.get rw_perm.buf_length |> Int63.of_int) let refresh_end_poff t new_end_poff = match t.rw_perm with | Some _ -> Error `Rw_not_allowed | None -> - t.persisted_end_poff <- new_end_poff; + Atomic.set t.persisted_end_poff new_end_poff; Ok () let flush t = @@ -119,31 +132,33 @@ module Make (Io : Io.S) (Errs : Io_errors.S with module Io = Io) = struct let open Result_syntax in let open Int63.Syntax in let s = Buffer.contents rw_perm.buf in - let off = t.persisted_end_poff + t.dead_header_size in + let persisted_end_poff = Atomic.get t.persisted_end_poff in + let off = persisted_end_poff + t.dead_header_size in let+ () = Io.write_string t.io ~off s in - t.persisted_end_poff <- - t.persisted_end_poff + (String.length s |> Int63.of_int); + Atomic.set rw_perm.buf_length 0; + Atomic.set t.persisted_end_poff + (persisted_end_poff + (String.length s |> Int63.of_int)); (* [truncate] is semantically identical to [clear], except that [truncate] doesn't deallocate the internal buffer. We use [clear] in legacy_io. *) Buffer.truncate rw_perm.buf 0; - rw_perm.fsync_required <- true + Atomic.set rw_perm.fsync_required true let fsync t = match t.rw_perm with | None -> Error `Ro_not_allowed | Some rw -> assert (Buffer.length rw.buf = 0); - if rw.fsync_required then + if Atomic.get rw.fsync_required then let open Result_syntax in let+ () = Io.fsync t.io in - rw.fsync_required <- false + Atomic.set rw.fsync_required true else Ok () let read_exn t ~off ~len b = let open Int63.Syntax in let off' = off + Int63.of_int len in - if off' > t.persisted_end_poff then + if off' > Atomic.get t.persisted_end_poff then raise (Errors.Pack_error `Read_out_of_bounds); let off = off + t.dead_header_size in Io.read_exn t.io ~off ~len b @@ -151,7 +166,7 @@ module Make (Io : Io.S) (Errs : Io_errors.S with module Io = Io) = struct let read_to_string t ~off ~len = let open Int63.Syntax in let off' = off + Int63.of_int len in - if off' > t.persisted_end_poff then Error `Read_out_of_bounds + if off' > Atomic.get t.persisted_end_poff then Error `Read_out_of_bounds else let off = off + t.dead_header_size in Io.read_to_string t.io ~off ~len @@ -162,6 +177,9 @@ module Make (Io : Io.S) (Errs : Io_errors.S with module Io = Io) = struct | Some rw_perm -> assert (Buffer.length rw_perm.buf < auto_flush_threshold); Buffer.add_string rw_perm.buf s; - if Buffer.length rw_perm.buf >= auto_flush_threshold then + let buf_length = + Atomic.fetch_and_add rw_perm.buf_length (String.length s) + in + if buf_length >= rw_perm.auto_flush_threshold then flush t |> Errs.raise_if_error end From 427a919789e76aaf02d41e134657daa6d1ea2c12 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Mon, 3 Jul 2023 13:22:53 +0200 Subject: [PATCH 52/99] Fix irmin-pack Gc cancellation on close --- src/irmin-pack/unix/store.ml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/irmin-pack/unix/store.ml b/src/irmin-pack/unix/store.ml index 7d49df8c2b..be033aaeaa 100644 --- a/src/irmin-pack/unix/store.ml +++ b/src/irmin-pack/unix/store.ml @@ -223,8 +223,7 @@ module Maker (Config : Conf.S) = struct let is_allowed { fm; _ } = File_manager.gc_allowed fm let behaviour { fm; _ } = File_manager.gc_behaviour fm - let cancel t = - Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> + let unsafe_cancel t = match t.running_gc with | Some { gc; _ } -> let cancelled = Gc.cancel gc in @@ -232,6 +231,9 @@ module Maker (Config : Conf.S) = struct cancelled | None -> false + let cancel t = + Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> unsafe_cancel t + let direct_commit_key t key = let state : _ Pack_key.state = Pack_key.inspect key in match state with @@ -455,7 +457,7 @@ module Maker (Config : Conf.S) = struct let close t = (* Step 1 - Kill the gc process if it is running *) - let _ = Gc.cancel t in + let _ = Gc.unsafe_cancel t in (* Step 2 - Close the files *) let () = File_manager.close t.fm |> Errs.raise_if_error in Branch.close t.branch; From 1a3249e867e55b31ee018f3bfead5fc272fcd31d Mon Sep 17 00:00:00 2001 From: ArthurW Date: Mon, 3 Jul 2023 13:24:46 +0200 Subject: [PATCH 53/99] Fix irmin-pack Async Gc status handling --- src/irmin-pack/unix/async.ml | 24 ++++++++++++++---------- 1 file changed, 14 insertions(+), 10 deletions(-) diff --git a/src/irmin-pack/unix/async.ml b/src/irmin-pack/unix/async.ml index e26f60fb6a..6332a10c7f 100644 --- a/src/irmin-pack/unix/async.ml +++ b/src/irmin-pack/unix/async.ml @@ -28,19 +28,20 @@ module Unix = struct (** [Exit] is a stack of PIDs that will be killed [at_exit]. *) module Exit = struct let proc_list = ref [] - let m = Mutex.create () + let m = Eio.Mutex.create () let add pid = - Mutex.lock m; - proc_list := pid :: !proc_list; - Mutex.unlock m + Eio.Mutex.use_rw ~protect:true m @@ fun () -> + proc_list := pid :: !proc_list let remove pid = - Mutex.lock m; - proc_list := List.filter (fun pid' -> pid <> pid') !proc_list; - Mutex.unlock m + Eio.Mutex.use_rw ~protect:true m @@ fun () -> + proc_list := List.filter (fun pid' -> pid <> pid') !proc_list - let () = at_exit @@ fun () -> List.iter kill_no_err !proc_list + let () = + at_exit @@ fun () -> + Eio.Mutex.use_rw ~protect:true m @@ fun () -> + List.iter kill_no_err !proc_list end type outcome = [ `Success | `Cancelled | `Failure of string ] @@ -49,7 +50,7 @@ module Unix = struct type status = [ `Running | `Success | `Cancelled | `Failure of string ] [@@deriving irmin] - type t = { pid : int; mutable status : status } + type t = { pid : int; mutable status : status; lock : Eio.Mutex.t } module Exit_code = struct let success = 0 @@ -74,7 +75,7 @@ module Unix = struct Unix._exit exit_code | pid -> Exit.add pid; - { pid; status = `Running } + { pid; status = `Running; lock = Eio.Mutex.create () } let status_of_process_outcome = function | Unix.WEXITED n when n = Exit_code.success -> `Success @@ -85,6 +86,7 @@ module Unix = struct | Unix.WSTOPPED n -> `Failure (Fmt.str "Stopped %d" n) let cancel t = + Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> match t.status with | `Running -> let pid, _ = Unix.waitpid [ Unix.WNOHANG ] t.pid in @@ -98,6 +100,7 @@ module Unix = struct | _ -> false let status t = + Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> match t.status with | `Running -> let pid, status = Unix.waitpid [ Unix.WNOHANG ] t.pid in @@ -110,6 +113,7 @@ module Unix = struct | #outcome as s -> s let await t = + Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> match t.status with | `Running -> let pid, status = Unix.waitpid [] t.pid in From f3a2c5c1f3904320aef8c7d3c8c02f9ce7d64240 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Tue, 4 Jul 2023 16:39:39 +0200 Subject: [PATCH 54/99] Fix for append_only_file buffer length --- src/irmin-pack/unix/append_only_file.ml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/irmin-pack/unix/append_only_file.ml b/src/irmin-pack/unix/append_only_file.ml index b41cd29bca..d3e45481bc 100644 --- a/src/irmin-pack/unix/append_only_file.ml +++ b/src/irmin-pack/unix/append_only_file.ml @@ -101,7 +101,7 @@ module Make (Io : Io.S) (Errs : Io_errors.S with module Io = Io) = struct { io; persisted_end_poff; dead_header_size; rw_perm = None } let empty_buffer = function - | { rw_perm = Some { buf; _ }; _ } when Buffer.length buf > 0 -> false + | { rw_perm = Some { buf_length; _ }; _ } -> Atomic.get buf_length = 0 | _ -> true let close t = @@ -175,11 +175,12 @@ module Make (Io : Io.S) (Errs : Io_errors.S with module Io = Io) = struct match t.rw_perm with | None -> raise Errors.RO_not_allowed | Some rw_perm -> - assert (Buffer.length rw_perm.buf < auto_flush_threshold); + assert (Atomic.get rw_perm.buf_length < auto_flush_threshold); Buffer.add_string rw_perm.buf s; - let buf_length = + let (_ : int) = Atomic.fetch_and_add rw_perm.buf_length (String.length s) in + let buf_length = Atomic.get rw_perm.buf_length in if buf_length >= rw_perm.auto_flush_threshold then flush t |> Errs.raise_if_error end From 52969d9800f19a98abcfe19d9a6696d22757ec5b Mon Sep 17 00:00:00 2001 From: ArthurW Date: Tue, 4 Jul 2023 16:43:13 +0200 Subject: [PATCH 55/99] Fix index-unix flushing from another thread --- src/irmin-pack/unix/file_manager.ml | 5 +++-- test/irmin-pack/common.ml | 3 +-- test/irmin-pack/test_pack.ml | 1 + 3 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/irmin-pack/unix/file_manager.ml b/src/irmin-pack/unix/file_manager.ml index 98ef952ceb..9b79af63bc 100644 --- a/src/irmin-pack/unix/file_manager.ml +++ b/src/irmin-pack/unix/file_manager.ml @@ -177,9 +177,10 @@ struct (** Is expected to be called by the index when its append buffer is full so that the dependendies of index are flushes. When the function returns, index will flush itself. *) - let index_is_about_to_auto_flush_exn t = + let index_is_about_to_auto_flush_exn _t = Stats.incr_fm_field Auto_index; - flush_suffix_and_its_deps t |> Errs.raise_if_error + (* TODO: remove? flush_suffix_and_its_deps t |> Errs.raise_if_error *) + () (* Explicit flush ********************************************************* *) diff --git a/test/irmin-pack/common.ml b/test/irmin-pack/common.ml index 6e051d1339..a8db0ca762 100644 --- a/test/irmin-pack/common.ml +++ b/test/irmin-pack/common.ml @@ -176,9 +176,8 @@ struct let reopen_rw name = create ~readonly:false ~fresh:false name let close_pack t = - Index.close_exn t.index; + let _ = File_manager.flush t.fm in File_manager.close t.fm |> Errs.raise_if_error - (* closes pack and dict *) end module Alcotest = struct diff --git a/test/irmin-pack/test_pack.ml b/test/irmin-pack/test_pack.ml index 595089b959..0e26886e61 100644 --- a/test/irmin-pack/test_pack.ml +++ b/test/irmin-pack/test_pack.ml @@ -340,6 +340,7 @@ module Pack = struct let y1 = Pack.find t'.pack k1 in Alcotest.(check (option string)) "reload before filter" None y1; Index.filter t.index (fun _ -> true); + flush t.fm; reload t'.fm; let y1 = Pack.find t'.pack k1 in Alcotest.(check (option string)) "reload after filter" (Some x1) y1; From c889be60a8505ed599b14044459aec581c9b0bb6 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Tue, 4 Jul 2023 16:45:19 +0200 Subject: [PATCH 56/99] Fix irmin-pack Gc locks --- src/irmin-pack/unix/store.ml | 77 ++++++++++++++++++++---------------- src/irmin/store.ml | 17 ++++---- 2 files changed, 53 insertions(+), 41 deletions(-) diff --git a/src/irmin-pack/unix/store.ml b/src/irmin-pack/unix/store.ml index be033aaeaa..93da110252 100644 --- a/src/irmin-pack/unix/store.ml +++ b/src/irmin-pack/unix/store.ml @@ -154,8 +154,8 @@ module Maker (Config : Conf.S) = struct fm : File_manager.t; dict : Dict.t; dispatcher : Dispatcher.t; - mutable during_batch : bool; - mutable running_gc : running_gc option; + during_batch : bool Atomic.t; + running_gc : running_gc option Atomic.t; lock : Eio.Mutex.t; } @@ -197,8 +197,8 @@ module Maker (Config : Conf.S) = struct let path = Irmin_pack.Layout.V4.branch ~root in Branch.v ~fresh ~readonly path in - let during_batch = false in - let running_gc = None in + let during_batch = Atomic.make false in + let running_gc = Atomic.make None in let lock = Eio.Mutex.create () in { config; @@ -224,10 +224,10 @@ module Maker (Config : Conf.S) = struct let behaviour { fm; _ } = File_manager.gc_behaviour fm let unsafe_cancel t = - match t.running_gc with + match Atomic.get t.running_gc with | Some { gc; _ } -> let cancelled = Gc.cancel gc in - t.running_gc <- None; + Atomic.set t.running_gc None; cancelled | None -> false @@ -248,10 +248,10 @@ module Maker (Config : Conf.S) = struct let start ~unlink ~use_auto_finalisation ~output t commit_key = let open Result_syntax in - Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> [%log.info "GC: Starting on %a" pp_key commit_key]; let* () = - if t.during_batch then Error `Gc_forbidden_during_batch else Ok () + if Atomic.get t.during_batch then Error `Gc_forbidden_during_batch + else Ok () in let* commit_key = direct_commit_key t commit_key in let root = Conf.root t.config in @@ -260,6 +260,7 @@ module Maker (Config : Conf.S) = struct Error (`Gc_disallowed "Store does not support GC") else Ok () in + Eio.Mutex.use_rw ~protect:false t.lock @@ fun () -> let current_generation = File_manager.generation t.fm in let next_generation = current_generation + 1 in let lower_root = Conf.lower_root t.config in @@ -268,13 +269,12 @@ module Maker (Config : Conf.S) = struct ~dispatcher:t.dispatcher ~fm:t.fm ~contents:t.contents ~node:t.node ~commit:t.commit ~output commit_key in - t.running_gc <- Some { gc; use_auto_finalisation }; + Atomic.set t.running_gc (Some { gc; use_auto_finalisation }); Ok () let start_exn ?(unlink = true) ?(output = `Root) ~use_auto_finalisation t commit_key = - Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> - match t.running_gc with + match Atomic.get t.running_gc with | Some _ -> [%log.info "Repo is alreadying running GC. Skipping."]; false @@ -285,37 +285,39 @@ module Maker (Config : Conf.S) = struct match result with Ok _ -> true | Error e -> Errs.raise_error e) let finalise_exn ?(wait = false) t = - Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> let result = - match t.running_gc with + match Atomic.get t.running_gc with | None -> Ok `Idle | Some { gc; _ } -> - if t.during_batch then Error `Gc_forbidden_during_batch - else Gc.finalise ~wait gc + if Atomic.get t.during_batch then + Error `Gc_forbidden_during_batch + else + Eio.Mutex.use_rw ~protect:false t.lock @@ fun () -> + Gc.finalise ~wait gc in match result with | Ok (`Finalised _ as x) -> - t.running_gc <- None; + Atomic.set t.running_gc None; x | Ok waited -> waited | Error e -> - t.running_gc <- None; + Atomic.set t.running_gc None; Errs.raise_error e - let is_finished t = - Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> - Option.is_none t.running_gc + let is_finished t = Option.is_none (Atomic.get t.running_gc) let on_finalise t f = - Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> - match t.running_gc with + match Atomic.get t.running_gc with | None -> () - | Some { gc; _ } -> Gc.on_finalise gc f + | Some { gc; _ } -> + Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> + Gc.on_finalise gc f let try_auto_finalise_exn t = - match t.running_gc with + match Atomic.get t.running_gc with | None | Some { use_auto_finalisation = false; _ } -> () | Some { use_auto_finalisation = true; _ } -> + Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> let _ = finalise_exn ~wait:false t in () @@ -366,10 +368,11 @@ module Maker (Config : Conf.S) = struct if not launched then Errs.raise_error `Forbidden_during_gc in let gced = - Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> - match t.running_gc with + match Atomic.get t.running_gc with | None -> assert false - | Some { gc; _ } -> Gc.finalise_without_swap gc + | Some { gc; _ } -> + Eio.Mutex.use_rw ~protect:false t.lock @@ fun () -> + Gc.finalise_without_swap gc in let config = Irmin.Backend.Conf.add t.config Conf.Key.root path in let () = @@ -387,16 +390,17 @@ module Maker (Config : Conf.S) = struct let split t = let open Result_syntax in - Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> let readonly = Irmin_pack.Conf.readonly t.config in let* () = if not (is_split_allowed t) then Error `Split_disallowed else Ok () in let* () = if readonly then Error `Ro_not_allowed else Ok () in let* () = - if t.during_batch then Error `Split_forbidden_during_batch + if Atomic.get t.during_batch then + Error `Split_forbidden_during_batch else Ok () in + Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> File_manager.split t.fm let split_exn repo = split repo |> Errs.raise_if_error @@ -412,14 +416,14 @@ module Maker (Config : Conf.S) = struct let batch t f = [%log.debug "[pack] batch start"]; - Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> + Eio.Mutex.use_rw_exn t.lock @@ fun () -> let readonly = Irmin_pack.Conf.readonly t.config in if readonly then Errs.raise_error `Ro_not_allowed else let c0 = Mtime_clock.counter () in let try_finalise () = Gc.try_auto_finalise_exn t in let _ = try_finalise () in - t.during_batch <- true; + Atomic.set t.during_batch true; let contents = Contents.CA.cast t.contents in let node = Node.CA.Pack.cast t.node in let commit = Commit.CA.cast t.commit in @@ -429,13 +433,13 @@ module Maker (Config : Conf.S) = struct let on_success res = let s = Mtime_clock.count c0 |> Mtime.span_to_s in [%log.info "[pack] batch completed in %.6fs" s]; - t.during_batch <- false; + Atomic.set t.during_batch false; File_manager.flush t.fm |> Errs.raise_if_error; let _ = try_finalise () in res in let on_fail exn = - t.during_batch <- false; + Atomic.set t.during_batch false; [%log.info "[pack] batch failed. calling flush. (%s)" (Printexc.to_string exn)]; @@ -455,6 +459,11 @@ module Maker (Config : Conf.S) = struct | v -> on_success v | exception exn -> on_fail exn + let batch ?(lock = false) t f = + if lock then + Eio.Mutex.use_rw ~protect:false t.lock @@ fun () -> unsafe_batch t f + else unsafe_batch t f + let close t = (* Step 1 - Kill the gc process if it is running *) let _ = Gc.unsafe_cancel t in @@ -775,7 +784,7 @@ module Maker (Config : Conf.S) = struct |> Option.is_some let kill_gc (repo : X.Repo.t) = - match (repo.running_gc : X.Repo.running_gc option) with + match (Atomic.get repo.running_gc : X.Repo.running_gc option) with | None -> false | Some { gc; _ } -> ( try X.Gc.cancel gc diff --git a/src/irmin/store.ml b/src/irmin/store.ml index b54603cbb5..4849a63a65 100644 --- a/src/irmin/store.ml +++ b/src/irmin/store.ml @@ -174,15 +174,17 @@ module Make (B : Backend.S) = struct |> sealr let v ?(clear = true) r ~info ~parents tree = - B.Repo.batch r @@ fun contents_t node_t commit_t -> - let node = + let result = + B.Repo.batch ~lock:true r @@ fun contents_t node_t commit_t -> match Tree.destruct tree with - | `Node t -> Tree.export ~clear r contents_t node_t t - | `Contents _ -> invalid_arg "cannot add contents at the root" + | `Contents _ -> Error "cannot add contents at the root" + | `Node t -> + let node = Tree.export ~clear r contents_t node_t t in + let v = B.Commit.Val.v ~info ~node ~parents in + let key = B.Commit.add commit_t v in + Ok { r; key; v } in - let v = B.Commit.Val.v ~info ~node ~parents in - let key = B.Commit.add commit_t v in - { r; key; v } + match result with Ok t -> t | Error e -> invalid_arg e let node t = B.Commit.Val.node t.v let tree t = Tree.import_no_check t.r (`Node (node t)) @@ -772,6 +774,7 @@ module Make (B : Backend.S) = struct let info = info () in let parents = match parents with None -> s.parents | Some p -> p in let parents = List.map Commit.key parents in + Eio.Mutex.use_ro t.lock @@ fun () -> let c = Commit.v ~clear (repo t) ~info ~parents root in let r = add_commit t s.head (c, root_tree (Tree.destruct root)) in Ok (Some c, r) From 4f1b3da11878bedc308848de0ef3e4704d030115 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Tue, 4 Jul 2023 16:46:42 +0200 Subject: [PATCH 57/99] Add commit unit test --- test/irmin-pack/test_multicore.ml | 66 +++++++++++++++++++++++++------ 1 file changed, 55 insertions(+), 11 deletions(-) diff --git a/test/irmin-pack/test_multicore.ml b/test/irmin-pack/test_multicore.ml index 60c5e1b632..dbd3c0b192 100644 --- a/test/irmin-pack/test_multicore.ml +++ b/test/irmin-pack/test_multicore.ml @@ -65,6 +65,20 @@ let shape1 : shape = `Node [ ("a", `Contents "new_new_a"); ("b", `Contents "new_new_b") ] ); ] +let shape2 : shape = + `Node + [ + ("a", `Contents "a"); + ("c", `Node [ ("e", `Contents "ce") ]); + ( "f", + `Node + [ + ("g", `Node [ ("h", `Contents "updated") ]); + ("fresh", `Contents "added"); + ] ); + ("i", `Contents "i"); + ] + let rec flatten_shape acc path : shape -> _ = function | `Contents c -> (List.rev path, c) :: acc | `Node children -> @@ -81,25 +95,29 @@ let make_tree shape = let make_store shape = let repo = Store.Repo.v (Store.config ~fresh:true root) in - (* let store = Store.empty repo in *) let main = Store.main repo in let tree = make_tree shape in let () = Store.set_tree_exn ~info main [] tree in Store.Repo.close repo -let domains_spawn d_mgr ?(nb = 2) fn = - let count = Atomic.make 0 in +let domains_run d_mgr fns = + let count = Atomic.make (List.length fns) in let fibers = - List.init nb (fun _ () -> + List.map + (fun fn () -> Eio.Domain_manager.run d_mgr (fun () -> - Atomic.incr count; - while Atomic.get count < nb do + Atomic.decr count; + while Atomic.get count > 0 do Domain.cpu_relax () done; fn ())) + fns in Eio.Fiber.all fibers +let domains_spawn d_mgr ?(nb = 2) fn = + domains_run d_mgr @@ List.init nb (fun _ -> fn) + let find_all tree paths = List.iter (fun (path, expected) -> @@ -190,11 +208,7 @@ let test_add_remove d_mgr = let tree = List.fold_left (fun tree -> function - | `Add (path, contents) -> - Format.printf "[%i] add %s@." - (Domain.self () :> int) - (String.concat ";" path); - Tree.add tree path contents + | `Add (path, contents) -> Tree.add tree path contents | `Remove path -> Tree.remove tree path) tree patch in @@ -208,10 +222,40 @@ let test_add_remove d_mgr = domains_spawn ~nb:2 d_mgr add_all; Store.Repo.close repo +let test_commit d_mgr = + Logs.set_level None; + make_store shape0; + let repo = Store.Repo.v (Store.config ~readonly:false ~fresh:false root) in + let patch01 = diff_shape shape0 shape1 in + let patch02 = diff_shape shape0 shape2 in + let do_commit patch () = + List.iter + (fun op -> + let store = Store.main repo in + let tree = Store.Head.get store |> Store.Commit.tree in + let tree = + match op with + | `Add (name, contents) -> Tree.add tree name contents + | `Remove name -> Tree.remove tree name + in + Store.set_tree_exn ~info store [] tree) + patch; + let tree = Store.main repo |> Store.Head.get |> Store.Commit.tree in + List.iter + (function + | `Add (name, contents) -> + assert (Store.Tree.find tree name = Some contents) + | `Remove name -> assert (not (Store.Tree.mem tree name))) + patch + in + domains_run d_mgr [ do_commit patch01; do_commit patch02 ]; + Store.Repo.close repo + let tests d_mgr = let tc name fn = Alcotest.test_case name `Quick (fun () -> fn d_mgr) in [ tc "find" test_find; tc "length" test_length; tc "add / remove" test_add_remove; + tc "commit" test_commit; ] From a888e7dcf432947f08748a09b667ed6d0ef61e2b Mon Sep 17 00:00:00 2001 From: ArthurW Date: Tue, 4 Jul 2023 17:10:09 +0200 Subject: [PATCH 58/99] Fix irmin-pack batch in batch test --- src/irmin-pack/unix/store.ml | 1 - src/irmin/store.ml | 29 ++++++++++------------------- test/multirmin/dune | 1 - 3 files changed, 10 insertions(+), 21 deletions(-) diff --git a/src/irmin-pack/unix/store.ml b/src/irmin-pack/unix/store.ml index 93da110252..f4e1382579 100644 --- a/src/irmin-pack/unix/store.ml +++ b/src/irmin-pack/unix/store.ml @@ -416,7 +416,6 @@ module Maker (Config : Conf.S) = struct let batch t f = [%log.debug "[pack] batch start"]; - Eio.Mutex.use_rw_exn t.lock @@ fun () -> let readonly = Irmin_pack.Conf.readonly t.config in if readonly then Errs.raise_error `Ro_not_allowed else diff --git a/src/irmin/store.ml b/src/irmin/store.ml index 4849a63a65..935b4e8844 100644 --- a/src/irmin/store.ml +++ b/src/irmin/store.ml @@ -441,9 +441,7 @@ module Make (B : Backend.S) = struct type t = { repo : Repo.t; head_ref : head_ref; - mutable tree : (commit * tree) option; - (* cache for the store tree *) - lock : Eio.Mutex.t; + mutable tree : (commit * tree) option; (* cache for the store tree *) } let repo t = t.repo @@ -476,9 +474,7 @@ module Make (B : Backend.S) = struct in aux 1 - let of_ref repo head_ref = - let lock = Eio.Mutex.create () in - { lock; head_ref; repo; tree = None } + let of_ref repo head_ref = { head_ref; repo; tree = None } let err_invalid_branch t = let err = Fmt.str "%a is not a valid branch name." pp_branch t in @@ -545,7 +541,6 @@ module Make (B : Backend.S) = struct | `Head key -> Some key | `Empty -> None | `Branch name -> ( - Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> match Branch_store.find (branch_store t) name with | None -> None | Some k -> Commit.of_key t.repo k) @@ -630,9 +625,7 @@ module Make (B : Backend.S) = struct Branch_store.test_and_set (branch_store t) name ~test:(h test) ~set:(h set) - let test_and_set t ~test ~set = - Eio.Mutex.use_rw ~protect:true t.lock (fun () -> - test_and_set_unsafe t ~test ~set) + let test_and_set = test_and_set_unsafe let fast_forward t ?max_depth ?n new_head = let return x = if x then Ok () else Error (`Rejected :> ff_error) in @@ -677,8 +670,7 @@ module Make (B : Backend.S) = struct let c3 = Commit.of_key t.repo c3 in test_and_set_unsafe t ~test:head ~set:c3 |> Merge.ok in - Eio.Mutex.use_rw ~protect:true t.lock (fun () -> - retry_merge "merge_head" aux) + retry_merge "merge_head" aux end (* Retry an operation until the optimistic lock is happy. Ensure @@ -704,13 +696,12 @@ module Make (B : Backend.S) = struct let add_commit t old_head ((c, _) as tree) = match t.head_ref with | `Head head -> - Eio.Mutex.use_rw ~protect:true t.lock (fun () -> - if not (Commit.equal_opt old_head !head) then false - else ( - (* [head] is protected by [t.lock] *) - head := Some c; - t.tree <- Some tree; - true)) + if not (Commit.equal_opt old_head !head) then false + else ( + (* [head] is protected by [t.lock] *) + head := Some c; + t.tree <- Some tree; + true) | `Branch name -> (* concurrent handlers and/or process can modify the branch. Need to check that we are still working on the same diff --git a/test/multirmin/dune b/test/multirmin/dune index ffb0751ab7..e413b02b4d 100644 --- a/test/multirmin/dune +++ b/test/multirmin/dune @@ -1,4 +1,3 @@ (executable (name test) - (modules test) (libraries irmin irmin-test eio_main test_pack)) From 1634e904a50a88c76e864e34ad095feb97408ba0 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Tue, 4 Jul 2023 17:18:33 +0200 Subject: [PATCH 59/99] Fix irmin store mutable tree --- src/irmin/store.ml | 33 ++++++++++++++++++++------------- 1 file changed, 20 insertions(+), 13 deletions(-) diff --git a/src/irmin/store.ml b/src/irmin/store.ml index 935b4e8844..4dde08c54d 100644 --- a/src/irmin/store.ml +++ b/src/irmin/store.ml @@ -441,7 +441,9 @@ module Make (B : Backend.S) = struct type t = { repo : Repo.t; head_ref : head_ref; - mutable tree : (commit * tree) option; (* cache for the store tree *) + tree : (commit * tree) option Atomic.t; + (* cache for the store tree *) + lock : Eio.Mutex.t; } let repo t = t.repo @@ -474,7 +476,9 @@ module Make (B : Backend.S) = struct in aux 1 - let of_ref repo head_ref = { head_ref; repo; tree = None } + let of_ref repo head_ref = + let lock = Eio.Mutex.create () in + { lock; head_ref; repo; tree = Atomic.make None } let err_invalid_branch t = let err = Fmt.str "%a is not a valid branch name." pp_branch t in @@ -548,19 +552,22 @@ module Make (B : Backend.S) = struct [%log.debug "Head.find -> %a" Fmt.(option Commit.pp_key) h]; h - let tree_and_head t = + let rec tree_and_head t = match head t with | None -> None | Some h -> ( - match t.tree with + match Atomic.get t.tree with | Some (o, t) when Commit.equal o h -> Some (o, t) - | _ -> - t.tree <- None; - - (* the tree cache needs to be invalidated *) - let tree = Tree.import_no_check (repo t) (`Node (Commit.node h)) in - t.tree <- Some (h, tree); - Some (h, tree)) + | old -> + if Atomic.compare_and_set t.tree old None then + (* the tree cache needs to be invalidated *) + let tree = + Tree.import_no_check (repo t) (`Node (Commit.node h)) + in + if Atomic.compare_and_set t.tree None (Some (h, tree)) then + Some (h, tree) + else tree_and_head t + else tree_and_head t) let tree t = match tree_and_head t with @@ -700,7 +707,7 @@ module Make (B : Backend.S) = struct else ( (* [head] is protected by [t.lock] *) head := Some c; - t.tree <- Some tree; + Atomic.set t.tree (Some tree); true) | `Branch name -> (* concurrent handlers and/or process can modify the @@ -709,7 +716,7 @@ module Make (B : Backend.S) = struct let test = match old_head with None -> None | Some c -> Some c.key in let set = Some c.key in let r = Branch_store.test_and_set (branch_store t) name ~test ~set in - if r then t.tree <- Some tree; + if r then Atomic.set t.tree (Some tree); r let pp_write_error ppf = function From 7b12d9fbad3e0390bc8a62265c998d6b88e0acb0 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Wed, 5 Jul 2023 13:16:25 +0200 Subject: [PATCH 60/99] Fix commit write lock --- test/irmin-pack/test_multicore.ml | 50 +++++++++++++++++++++++-------- 1 file changed, 38 insertions(+), 12 deletions(-) diff --git a/test/irmin-pack/test_multicore.ml b/test/irmin-pack/test_multicore.ml index dbd3c0b192..ebee7dbf1b 100644 --- a/test/irmin-pack/test_multicore.ml +++ b/test/irmin-pack/test_multicore.ml @@ -222,35 +222,60 @@ let test_add_remove d_mgr = domains_spawn ~nb:2 d_mgr add_all; Store.Repo.close repo +let apply_op tree = function + | `Add (name, contents) -> Tree.add tree name contents + | `Remove name -> Tree.remove tree name + +let check_patch_was_applied patch tree = + List.iter + (function + | `Add (name, contents) -> + assert (Store.Tree.find tree name = Some contents) + | `Remove name -> assert (not (Store.Tree.mem tree name))) + patch + let test_commit d_mgr = Logs.set_level None; make_store shape0; let repo = Store.Repo.v (Store.config ~readonly:false ~fresh:false root) in + let store = Store.main repo in let patch01 = diff_shape shape0 shape1 in let patch02 = diff_shape shape0 shape2 in let do_commit patch () = List.iter (fun op -> - let store = Store.main repo in let tree = Store.Head.get store |> Store.Commit.tree in - let tree = - match op with - | `Add (name, contents) -> Tree.add tree name contents - | `Remove name -> Tree.remove tree name - in + let tree = apply_op tree op in Store.set_tree_exn ~info store [] tree) patch; let tree = Store.main repo |> Store.Head.get |> Store.Commit.tree in - List.iter - (function - | `Add (name, contents) -> - assert (Store.Tree.find tree name = Some contents) - | `Remove name -> assert (not (Store.Tree.mem tree name))) - patch + check_patch_was_applied patch tree in domains_run d_mgr [ do_commit patch01; do_commit patch02 ]; Store.Repo.close repo +let test_merkle d_mgr = + Logs.set_level None; + make_store shape0; + let repo = Store.Repo.v (Store.config ~readonly:false ~fresh:false root) in + let tree = Store.main repo |> Store.Head.get |> Store.Commit.tree in + let hash = Store.Tree.key tree |> Option.get in + let patch01 = diff_shape shape0 shape1 in + let patch02 = diff_shape shape0 shape2 in + let do_proof patch () = + let fn tree = + let new_tree = List.fold_left apply_op tree patch in + new_tree, () + in + let proof, () = Store.Tree.produce_proof repo hash fn in + match Store.Tree.verify_proof proof fn with + | Ok (new_tree, ()) -> + check_patch_was_applied patch new_tree + | Error _ -> assert false + in + domains_run d_mgr [ do_proof patch01; do_proof patch02 ]; + Store.Repo.close repo + let tests d_mgr = let tc name fn = Alcotest.test_case name `Quick (fun () -> fn d_mgr) in [ @@ -258,4 +283,5 @@ let tests d_mgr = tc "length" test_length; tc "add / remove" test_add_remove; tc "commit" test_commit; + tc "merkle" test_merkle; ] From c26e8eb3d638039ae26c3f46346d5d36a9f28662 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Wed, 5 Jul 2023 14:26:23 +0200 Subject: [PATCH 61/99] Fix parallel tree hash computation --- src/irmin/tree.ml | 18 ++++++++++--- test/irmin-pack/test_multicore.ml | 45 ++++++++++++++++++++++++------- 2 files changed, 50 insertions(+), 13 deletions(-) diff --git a/src/irmin/tree.ml b/src/irmin/tree.ml index 2e324bb284..43fbd3278a 100644 --- a/src/irmin/tree.ml +++ b/src/irmin/tree.ml @@ -347,6 +347,12 @@ module Make (P : Backend.S) = struct | None -> None | Some c -> Some c)) + let set_hash_cache ~cache t hash = + let (_ : bool) = + cache && Atomic.compare_and_set t.info.ptr Ptr_none (Hash hash) + in + () + let hash ?(cache = true) c = match cached_hash c with | Some k -> k @@ -356,8 +362,7 @@ module Make (P : Backend.S) = struct | Some v -> Atomic.incr cnt.contents_hash; let h = P.Contents.Hash.hash v in - assert (Atomic.get c.info.ptr = Ptr_none); - if cache then Atomic.set c.info.ptr (Hash h); + set_hash_cache ~cache c h; h) let key t = @@ -921,13 +926,18 @@ module Make (P : Backend.S) = struct | `Contents (key, m) -> `Contents (P.Contents.Key.to_hash key, m) | `Node key -> `Node (P.Node.Key.to_hash key) + let set_hash_cache ~cache t hash = + let (_ : bool) = + cache && Atomic.compare_and_set t.info.ptr Ptr_none (Hash hash) + in + () + let rec hash : type a. cache:bool -> t -> (hash -> a) -> a = fun ~cache t k -> let a_of_hashable hash v = Atomic.incr cnt.node_hash; let hash = hash v in - assert (Atomic.get t.info.ptr = Ptr_none); - if cache then Atomic.set t.info.ptr (Hash hash); + set_hash_cache ~cache t hash; k hash in match diff --git a/test/irmin-pack/test_multicore.ml b/test/irmin-pack/test_multicore.ml index ebee7dbf1b..1c4d62693a 100644 --- a/test/irmin-pack/test_multicore.ml +++ b/test/irmin-pack/test_multicore.ml @@ -227,12 +227,12 @@ let apply_op tree = function | `Remove name -> Tree.remove tree name let check_patch_was_applied patch tree = - List.iter - (function - | `Add (name, contents) -> - assert (Store.Tree.find tree name = Some contents) - | `Remove name -> assert (not (Store.Tree.mem tree name))) - patch + List.iter + (function + | `Add (name, contents) -> + assert (Store.Tree.find tree name = Some contents) + | `Remove name -> assert (not (Store.Tree.mem tree name))) + patch let test_commit d_mgr = Logs.set_level None; @@ -265,17 +265,43 @@ let test_merkle d_mgr = let do_proof patch () = let fn tree = let new_tree = List.fold_left apply_op tree patch in - new_tree, () + (new_tree, ()) in let proof, () = Store.Tree.produce_proof repo hash fn in match Store.Tree.verify_proof proof fn with - | Ok (new_tree, ()) -> - check_patch_was_applied patch new_tree + | Ok (new_tree, ()) -> check_patch_was_applied patch new_tree | Error _ -> assert false in domains_run d_mgr [ do_proof patch01; do_proof patch02 ]; Store.Repo.close repo +let test_hash d_mgr = + Logs.set_level None; + make_store shape0; + let repo = Store.Repo.v (Store.config ~readonly:false ~fresh:false root) in + let tree = Store.main repo |> Store.Head.get |> Store.Commit.tree in + let patch01 = diff_shape shape0 shape1 in + let patch12 = diff_shape shape1 shape2 in + let patch = patch01 @ patch12 in + let _, trees = + List.fold_left + (fun (tree, trees) op -> + let new_tree = apply_op tree op in + (new_tree, new_tree :: trees)) + (tree, [ tree ]) patch + in + let do_hash result () = + let hashes = List.map Store.Tree.hash trees in + Atomic.set result hashes + in + let result1 = Atomic.make [] in + let result2 = Atomic.make [] in + domains_run d_mgr [ do_hash result1; do_hash result2 ]; + List.iter2 + (fun h1 h2 -> assert (h1 = h2)) + (Atomic.get result1) (Atomic.get result2); + Store.Repo.close repo + let tests d_mgr = let tc name fn = Alcotest.test_case name `Quick (fun () -> fn d_mgr) in [ @@ -284,4 +310,5 @@ let tests d_mgr = tc "add / remove" test_add_remove; tc "commit" test_commit; tc "merkle" test_merkle; + tc "hash" test_hash; ] From d086dad83f86281ba985548d8e25a6db9adffa2d Mon Sep 17 00:00:00 2001 From: gwenaelle Date: Wed, 5 Jul 2023 15:58:49 +0200 Subject: [PATCH 62/99] irmin-pack: Add Store.Tree.list test --- test/irmin-pack/test_multicore.ml | 47 +++++++++++++++++++++++++++++++ 1 file changed, 47 insertions(+) diff --git a/test/irmin-pack/test_multicore.ml b/test/irmin-pack/test_multicore.ml index 1c4d62693a..e078e0cd72 100644 --- a/test/irmin-pack/test_multicore.ml +++ b/test/irmin-pack/test_multicore.ml @@ -93,6 +93,17 @@ let make_tree shape = (fun tree (k, v) -> Tree.add tree k v) (Tree.empty ()) (flatten_shape shape) +let rec list_shape acc path : shape -> _ = function + | `Contents _c -> (List.rev path, []) :: acc + | `Node children -> + let l = List.map (fun (name, child) -> (name, make_tree child)) children in + let acc = (List.rev path, l) :: acc in + List.fold_left + (fun acc (name, child) -> list_shape acc (name :: path) child) + acc children + +let list_shape shape = list_shape [] [] shape + let make_store shape = let repo = Store.Repo.v (Store.config ~fresh:true root) in let main = Store.main repo in @@ -302,6 +313,38 @@ let test_hash d_mgr = (Atomic.get result1) (Atomic.get result2); Store.Repo.close repo +let list_all cache tree paths = + List.iter + (fun (path, expected) -> + let value = Store.Tree.list ~cache tree path in + assert (List.length expected = List.length value); + List.iter (fun (s, t) -> + let t' = List.assoc s value in + let diffs = Store.Tree.diff t t' in + assert (diffs = []) + ) expected) + paths + +let test_list_disk ~cache d_mgr = + Logs.set_level None; + make_store shape0; + let repo = Store.Repo.v (Store.config ~readonly:true ~fresh:false root) in + let tree = Store.main repo |> Store.Head.get |> Store.Commit.tree in + let paths = list_shape shape0 in + domains_spawn d_mgr (fun () -> list_all cache tree paths); + Store.Repo.close repo + +let test_list_mem ~cache d_mgr = + Logs.set_level None; + make_store shape0; + let repo = Store.Repo.v (Store.config ~readonly:true ~fresh:false root) in + let tree = Store.main repo |> Store.Head.get |> Store.Commit.tree in + let patch = diff_shape shape0 shape1 in + let paths = list_shape shape1 in + let tree = List.fold_left apply_op tree patch in + domains_spawn d_mgr (fun _ -> list_all cache tree paths); + Store.Repo.close repo + let tests d_mgr = let tc name fn = Alcotest.test_case name `Quick (fun () -> fn d_mgr) in [ @@ -311,4 +354,8 @@ let tests d_mgr = tc "commit" test_commit; tc "merkle" test_merkle; tc "hash" test_hash; + tc "list-disk-no-cache" (test_list_disk ~cache:false); + tc "list-disk-with-cache" (test_list_disk ~cache:true); + tc "list-mem-no-cache" (test_list_mem ~cache:false); + tc "list-mem-with-cache" (test_list_mem ~cache:true); ] From 24c3edd62affa268f453aaf1b8ee225c8de00ec2 Mon Sep 17 00:00:00 2001 From: gwenaelle Date: Wed, 5 Jul 2023 17:18:52 +0200 Subject: [PATCH 63/99] irmin-pack: Add tests on commits for of_hash & parents --- test/irmin-pack/test_multicore.ml | 73 ++++++++++++++++++++++++++++++- 1 file changed, 72 insertions(+), 1 deletion(-) diff --git a/test/irmin-pack/test_multicore.ml b/test/irmin-pack/test_multicore.ml index e078e0cd72..538f72c2a5 100644 --- a/test/irmin-pack/test_multicore.ml +++ b/test/irmin-pack/test_multicore.ml @@ -345,7 +345,76 @@ let test_list_mem ~cache d_mgr = domains_spawn d_mgr (fun _ -> list_all cache tree paths); Store.Repo.close repo -let tests d_mgr = +let test_commit_of_hash d_mgr = + Logs.set_level None; + make_store shape0; + let repo = Store.Repo.v (Store.config ~readonly:false ~fresh:false root) in + let store = Store.main repo in + let patch01 = diff_shape shape0 shape1 in + let patch02 = diff_shape shape0 shape2 in + let commit1 = Store.Head.get store in + let hash1 = Store.Commit.hash commit1 in + let tree1 = Store.Commit.tree commit1 in + List.iter + (fun op -> + let tree = Store.Commit.tree commit1 in + let tree = apply_op tree op in + Store.set_tree_exn ~info store [] tree) + patch01; + let commit2 = Store.Head.get store in + let hash2 = Store.Commit.hash commit2 in + let tree2 = Store.Commit.tree commit2 in + List.iter + (fun op -> + let tree = Store.Commit.tree commit2 in + let tree = apply_op tree op in + Store.set_tree_exn ~info store [] tree) + patch02; + let commit3 = Store.Head.get store in + let hash3 = Store.Commit.hash commit3 in + let tree3 = Store.Commit.tree commit3 in + let do_commit_of_hash () = + let t1 = Store.Commit.of_hash repo hash1 |> Option.get |> Store.Commit.tree in + let diffs = Store.Tree.diff tree1 t1 in + assert (diffs = []); + let t2 = Store.Commit.of_hash repo hash2 |> Option.get |> Store.Commit.tree in + let diffs = Store.Tree.diff tree2 t2 in + assert (diffs = []); + let t3 = Store.Commit.of_hash repo hash3 |> Option.get |> Store.Commit.tree in + let diffs = Store.Tree.diff tree3 t3 in + assert (diffs = []) + in + domains_spawn d_mgr do_commit_of_hash; + Store.Repo.close repo + +let test_commit_parents d_mgr = + Logs.set_level None; + make_store shape0; + let repo = Store.Repo.v (Store.config ~readonly:false ~fresh:false root) in + let store = Store.main repo in + let patch01 = diff_shape shape0 shape1 in + let commit = Store.Head.get store in + let tree = Store.Commit.tree commit in + let commits = + snd @@ List.fold_left_map + (fun tree op -> + let tree = apply_op tree op in + Store.set_tree_exn ~info store [] tree; + tree, Store.Head.get store) tree patch01 + in + let do_commit_parents () = + ignore + (List.fold_left + (fun parent commit -> + let parents = Store.Commit.parents commit in + assert (parents = [Store.Commit.key parent]); + commit) + commit commits) + in + domains_spawn d_mgr do_commit_parents; + Store.Repo.close repo + + let tests d_mgr = let tc name fn = Alcotest.test_case name `Quick (fun () -> fn d_mgr) in [ tc "find" test_find; @@ -358,4 +427,6 @@ let tests d_mgr = tc "list-disk-with-cache" (test_list_disk ~cache:true); tc "list-mem-no-cache" (test_list_mem ~cache:false); tc "list-mem-with-cache" (test_list_mem ~cache:true); + tc "commit-of-hash" test_commit_of_hash; + tc "commit-parents" test_commit_parents; ] From dd1c41fbf6a8280574748b9361c69d48c0360ea8 Mon Sep 17 00:00:00 2001 From: gwenaelle Date: Wed, 5 Jul 2023 18:05:57 +0200 Subject: [PATCH 64/99] irmin-pack: Add Commit.v test & fix it with a lock --- src/irmin-git/backend.ml | 2 +- src/irmin-git/irmin_git.ml | 2 +- src/irmin-pack/mem/irmin_pack_mem.ml | 2 +- src/irmin-pack/unix/store.ml | 2 +- src/irmin/backend.ml | 2 +- src/irmin/irmin.ml | 2 +- test/irmin-pack/test_multicore.ml | 40 +++++++++++++++++++--------- test/irmin-pack/test_snapshot.ml | 2 +- 8 files changed, 35 insertions(+), 19 deletions(-) diff --git a/src/irmin-git/backend.ml b/src/irmin-git/backend.ml index 49d3fbe154..f4c76e09d3 100644 --- a/src/irmin-git/backend.ml +++ b/src/irmin-git/backend.ml @@ -79,7 +79,7 @@ struct let contents_t t : 'a Contents.t = (t.closed, t.g) let node_t t : 'a Node.t = (contents_t t, (t.closed, t.g)) let commit_t t : 'a Commit.t = (node_t t, (t.closed, t.g)) - let batch t f = f (contents_t t) (node_t t) (commit_t t) + let batch ?lock:_ t f = f (contents_t t) (node_t t) (commit_t t) type config = { root : string; diff --git a/src/irmin-git/irmin_git.ml b/src/irmin-git/irmin_git.ml index 6fc6b03724..c91ff38e4c 100644 --- a/src/irmin-git/irmin_git.ml +++ b/src/irmin-git/irmin_git.ml @@ -313,7 +313,7 @@ struct let branch_t t = t.branch let config t = t.config - let batch t f = + let batch ?lock:_ t f = Contents.CA.batch t.contents @@ fun c -> Node.CA.batch (snd t.nodes) @@ fun n -> Commit.CA.batch (snd t.commits) @@ fun ct -> diff --git a/src/irmin-pack/mem/irmin_pack_mem.ml b/src/irmin-pack/mem/irmin_pack_mem.ml index 0a09d78b3c..3d7bdc5f5f 100644 --- a/src/irmin-pack/mem/irmin_pack_mem.ml +++ b/src/irmin-pack/mem/irmin_pack_mem.ml @@ -140,7 +140,7 @@ module Maker (Config : Irmin_pack.Conf.S) = struct let branch_t t = t.branch let config t = t.config - let batch t f = + let batch ?lock:_ t f = Commit.Indexable.batch t.commit (fun commit -> Node.Indexable.batch t.node (fun node -> Contents.Indexable.batch t.contents (fun contents -> diff --git a/src/irmin-pack/unix/store.ml b/src/irmin-pack/unix/store.ml index f4e1382579..4713db1db4 100644 --- a/src/irmin-pack/unix/store.ml +++ b/src/irmin-pack/unix/store.ml @@ -414,7 +414,7 @@ module Maker (Config : Conf.S) = struct in File_manager.add_volume t.fm |> Errs.raise_if_error - let batch t f = + let unsafe_batch t f = [%log.debug "[pack] batch start"]; let readonly = Irmin_pack.Conf.readonly t.config in if readonly then Errs.raise_error `Ro_not_allowed diff --git a/src/irmin/backend.ml b/src/irmin/backend.ml index 78492d9e23..97cef5d19a 100644 --- a/src/irmin/backend.ml +++ b/src/irmin/backend.ml @@ -98,7 +98,7 @@ module type S = sig val config : t -> Conf.t val batch : - t -> + ?lock:bool -> t -> (read_write Contents.t -> read_write Node.t -> read_write Commit.t -> 'a) -> 'a (** A getter from repo to backend stores in rw mode. *) diff --git a/src/irmin/irmin.ml b/src/irmin/irmin.ml index c932beff32..e5f3380ffc 100644 --- a/src/irmin/irmin.ml +++ b/src/irmin/irmin.ml @@ -115,7 +115,7 @@ module Maker_generic_key (Backend : Maker_generic_key_args) = struct let branch_t t = t.branch let config t = t.config - let batch t f = + let batch ?lock:_ t f = Contents.Backend.batch t.contents @@ fun c -> Node.Backend.batch (snd t.nodes) @@ fun n -> Commit.Backend.batch (snd t.commits) @@ fun ct -> diff --git a/test/irmin-pack/test_multicore.ml b/test/irmin-pack/test_multicore.ml index 538f72c2a5..4a7112bc1f 100644 --- a/test/irmin-pack/test_multicore.ml +++ b/test/irmin-pack/test_multicore.ml @@ -414,19 +414,35 @@ let test_commit_parents d_mgr = domains_spawn d_mgr do_commit_parents; Store.Repo.close repo +let test_commit_v d_mgr = + Logs.set_level None; + make_store shape0; + let repo = Store.Repo.v (Store.config ~readonly:false ~fresh:false root) in + let store = Store.main repo in + let patch01 = diff_shape shape0 shape1 in + let commit = Store.Head.get store in + let tree = List.fold_left apply_op (Store.Commit.tree commit) patch01 in + let do_commit_v () = + let _ = Store.Commit.v repo ~info:(info ()) ~parents:[Store.Commit.key commit] tree in + () + in + domains_spawn d_mgr do_commit_v; + Store.Repo.close repo + let tests d_mgr = let tc name fn = Alcotest.test_case name `Quick (fun () -> fn d_mgr) in [ - tc "find" test_find; - tc "length" test_length; - tc "add / remove" test_add_remove; - tc "commit" test_commit; - tc "merkle" test_merkle; - tc "hash" test_hash; - tc "list-disk-no-cache" (test_list_disk ~cache:false); - tc "list-disk-with-cache" (test_list_disk ~cache:true); - tc "list-mem-no-cache" (test_list_mem ~cache:false); - tc "list-mem-with-cache" (test_list_mem ~cache:true); - tc "commit-of-hash" test_commit_of_hash; - tc "commit-parents" test_commit_parents; + tc "find." test_find; + tc "length." test_length; + tc "add / remove." test_add_remove; + tc "commit." test_commit; + tc "merkle." test_merkle; + tc "hash." test_hash; + tc "list-disk-no-cache." (test_list_disk ~cache:false); + tc "list-disk-with-cache." (test_list_disk ~cache:true); + tc "list-mem-no-cache." (test_list_mem ~cache:false); + tc "list-mem-with-cache." (test_list_mem ~cache:true); + tc "commit-of-hash." test_commit_of_hash; + tc "commit-parents." test_commit_parents; + tc "commit-v." test_commit_v; ] diff --git a/test/irmin-pack/test_snapshot.ml b/test/irmin-pack/test_snapshot.ml index 023d5923c9..9941339a63 100644 --- a/test/irmin-pack/test_snapshot.ml +++ b/test/irmin-pack/test_snapshot.ml @@ -299,6 +299,6 @@ let tests = tc "on disk always" test_on_disk_always; tc "gced store, in memory" test_gced_store_in_memory; tc "gced store, on disk" test_gced_store_on_disk; - tc "import old snapshot, export gc based snapshot " + tc "import old snapshot, export gc based snapshot" test_export_import_reexport; ] From 17da4c8ee3c2d521f9b25b4816218bf8d4dfcf7b Mon Sep 17 00:00:00 2001 From: ArthurW Date: Wed, 5 Jul 2023 16:14:56 +0200 Subject: [PATCH 65/99] Fix libirmin: at_exit executes outside of eio --- src/irmin-pack/unix/async.ml | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/src/irmin-pack/unix/async.ml b/src/irmin-pack/unix/async.ml index 6332a10c7f..f843f42abe 100644 --- a/src/irmin-pack/unix/async.ml +++ b/src/irmin-pack/unix/async.ml @@ -27,21 +27,23 @@ module Unix = struct (** [Exit] is a stack of PIDs that will be killed [at_exit]. *) module Exit = struct - let proc_list = ref [] - let m = Eio.Mutex.create () + let proc_list = Atomic.make [] - let add pid = - Eio.Mutex.use_rw ~protect:true m @@ fun () -> - proc_list := pid :: !proc_list + let rec add pid = + let pids = Atomic.get proc_list in + if not (Atomic.compare_and_set proc_list pids (pid :: pids)) + then add pid - let remove pid = - Eio.Mutex.use_rw ~protect:true m @@ fun () -> - proc_list := List.filter (fun pid' -> pid <> pid') !proc_list + let rec remove pid = + let pids = Atomic.get proc_list in + let new_pids = List.filter (fun pid' -> pid <> pid') pids in + if not (Atomic.compare_and_set proc_list pids new_pids) + then remove pid let () = at_exit @@ fun () -> - Eio.Mutex.use_rw ~protect:true m @@ fun () -> - List.iter kill_no_err !proc_list + let pids = Atomic.exchange proc_list [] in + List.iter kill_no_err pids end type outcome = [ `Success | `Cancelled | `Failure of string ] From 3d6dea1d93a1ab929d83c73e7c5ffa098529fb19 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Mon, 10 Jul 2023 12:46:53 +0200 Subject: [PATCH 66/99] Add half and full diamond multicore benchmarks --- test/irmin-pack/bench_multicore/bench.ml | 157 +++++++++++++++++++++ test/irmin-pack/bench_multicore/dune | 3 + test/irmin-pack/bench_multicore/gen.ml | 132 +++++++++++++++++ test/irmin-pack/bench_multicore/main.ml | 147 +++++++++++++++++++ test/irmin-pack/bench_multicore/workers.ml | 35 +++++ 5 files changed, 474 insertions(+) create mode 100644 test/irmin-pack/bench_multicore/bench.ml create mode 100644 test/irmin-pack/bench_multicore/dune create mode 100644 test/irmin-pack/bench_multicore/gen.ml create mode 100644 test/irmin-pack/bench_multicore/main.ml create mode 100644 test/irmin-pack/bench_multicore/workers.ml diff --git a/test/irmin-pack/bench_multicore/bench.ml b/test/irmin-pack/bench_multicore/bench.ml new file mode 100644 index 0000000000..919b8f5aac --- /dev/null +++ b/test/irmin-pack/bench_multicore/bench.ml @@ -0,0 +1,157 @@ +module S = Irmin_tezos.Store +module Tree = S.Tree + +let make_tree_of_paths paths = + Array.fold_left + (fun tree (path, contents) -> Tree.add tree path contents) + (Tree.empty ()) paths + +let goto_project_root () = + let cwd = Fpath.v (Sys.getcwd ()) in + match cwd |> Fpath.segs |> List.rev with + | "bench_multicore" :: "irmin-pack" :: "test" :: "default" :: "_build" :: root + | "bench_multicore" :: "irmin-pack" :: "test" :: root -> + Unix.chdir @@ String.concat Fpath.dir_sep @@ List.rev root + | _ -> () + +let root = Filename.concat "_build" "bench-multicore" + +let reset_test_env () = + goto_project_root (); + Common.rm_dir root + +let info () = S.Info.empty + +let open_repo ~fresh ~readonly () = + let conf = Irmin_pack.Conf.init ~fresh ~readonly root in + S.Repo.v conf + +let apply_op tree = function + | Gen.Find path -> + let _ = Tree.find tree path in + tree + | Add (path, contents) -> Tree.add tree path contents + | Rem path -> Tree.remove tree path + +let half_task tree task = + let _ = Array.fold_left apply_op tree task in + () + +let full_task i tree_at task = + let path = [ string_of_int i ] in + let tree = Atomic.get tree_at in + let new_tree = Array.fold_left apply_op tree task in + let new_subtree = Option.get @@ Tree.find_tree new_tree path in + let rec update () = + let current_tree = Atomic.get tree_at in + let new_tree = Tree.add_tree current_tree path new_subtree in + if not (Atomic.compare_and_set tree_at current_tree new_tree) then update () + in + update () + +let warmup_task tree task = + Array.iter + (function + | Gen.Find path | Add (path, _) | Rem path -> + ignore @@ Tree.find tree path) + task + +let analyze_bench timers = + let n = Array.length timers in + Array.sort Float.compare timers; + let mean = timers.(n / 2) in + (timers.(0), mean, timers.(n - 1)) + +let bench ?(samples = 5) fn = + let timers = + Array.init samples (fun _ -> + let t0 = Unix.gettimeofday () in + fn (); + let t1 = Unix.gettimeofday () in + let sequential = 1000.0 *. (t1 -. t0) in + sequential) + in + analyze_bench timers + +let get_tree repo = S.main repo |> S.Head.get |> S.Commit.tree + +let get_tree ~config repo tasks = + if not config.Gen.warm then fun () -> get_tree repo + else + let tree = get_tree repo in + Array.iter (warmup_task tree) tasks; + fun () -> tree + +let setup_tree ~readonly paths = + let tree = make_tree_of_paths paths in + reset_test_env (); + let repo = open_repo ~fresh:true ~readonly:false () in + let () = S.set_tree_exn ~info (S.main repo) [] tree in + S.Repo.close repo; + let repo = open_repo ~fresh:false ~readonly () in + Format.printf + "# domains,min_time,median_time,max_time,min_ratio,median_ratio,max_ratio@."; + repo + +let half ~d_mgr ~(config : Gen.config) = + let paths, tasks = Gen.make ~config in + let repo = setup_tree ~readonly:true paths in + let get_tree = get_tree ~config repo tasks in + + let _, sequential, _ = + bench ~samples:config.nb_runs @@ fun () -> + let tree = get_tree () in + Array.iter (half_task tree) tasks + in + + for nb_domains = 1 to Domain.recommended_domain_count () do + let elapsed = ref [] in + for _ = 1 to config.nb_runs do + let tree = get_tree () in + let tasks = Array.map (fun task () -> half_task tree task) tasks in + let dt = Workers.run ~d_mgr ~nb:nb_domains tasks in + elapsed := dt :: !elapsed + done; + let min, median, max = analyze_bench @@ Array.of_list !elapsed in + Format.printf "%i,%.2f,%.2f,%.2f,%.2f,%.2f,%.2f@." nb_domains min median max + (sequential /. max) (sequential /. median) (sequential /. min) + done; + S.Repo.close repo + +let full ~d_mgr ~(config : Gen.config) = + let paths, tasks = Gen.make_full ~config in + let repo = setup_tree ~readonly:false paths in + let get_tree = get_tree ~config repo tasks in + let parents = [ S.Commit.key @@ S.Head.get @@ S.main repo ] in + + let commit tree_at () = + let new_tree = Atomic.get tree_at in + let _ = S.Commit.v repo ~parents ~info:S.Info.empty new_tree in + () + in + + let _, sequential, _ = + bench ~samples:config.nb_runs @@ fun () -> + let tree_at = Atomic.make (get_tree ()) in + Array.iteri (fun i task -> full_task i tree_at task) tasks; + commit tree_at () + in + + for nb_domains = 1 to Domain.recommended_domain_count () do + let elapsed = ref [] in + for _ = 1 to config.nb_runs do + let tree = get_tree () in + let tree_at = Atomic.make tree in + let tasks = + Array.mapi (fun i task () -> full_task i tree_at task) tasks + in + let dt = + Workers.run ~d_mgr ~nb:nb_domains ~finally:(commit tree_at) tasks + in + elapsed := dt :: !elapsed + done; + let min, median, max = analyze_bench @@ Array.of_list !elapsed in + Format.printf "%i,%.2f,%.2f,%.2f,%.2f,%.2f,%.2f@." nb_domains min median max + (sequential /. max) (sequential /. median) (sequential /. min) + done; + S.Repo.close repo diff --git a/test/irmin-pack/bench_multicore/dune b/test/irmin-pack/bench_multicore/dune new file mode 100644 index 0000000000..1f12d22ab1 --- /dev/null +++ b/test/irmin-pack/bench_multicore/dune @@ -0,0 +1,3 @@ +(executable + (name main) + (libraries irmin irmin-test eio_main test_pack cmdliner)) diff --git a/test/irmin-pack/bench_multicore/gen.ml b/test/irmin-pack/bench_multicore/gen.ml new file mode 100644 index 0000000000..af20db6270 --- /dev/null +++ b/test/irmin-pack/bench_multicore/gen.ml @@ -0,0 +1,132 @@ +type range = int * int + +type config = { + elements : int; + branching : range; + balance : range; + name_length : range; + contents_length : range; + max_depth : int; + nb_tasks : int; + nb_finds : int; + nb_adds : int; + nb_rems : int; + nb_runs : int; + warm : bool; +} + +type path = string list +type op = Find of path | Add of path * bytes | Rem of path + +let random_range (min, max) = + if min >= max then min else min + Random.int (max - min) + +let random_string len = + String.init len (fun _ -> Char.chr (Char.code 'a' + Random.int 26)) + +let make_name config = + let len = random_range config.name_length in + random_string len + +let make_contents config = + let len = random_range config.contents_length in + Bytes.of_string @@ random_string len + +let make_balanced config quantity' = + assert (quantity' > 1); + let len = random_range config.branching in + let quantity = quantity' - len in + if quantity <= 0 then List.init (quantity' - 1) (fun _ -> 1) + else + let weights = List.init len (fun _ -> random_range config.balance) in + let total = List.fold_left ( + ) 0 weights in + let weights = List.map (fun w -> 1 + (quantity * w / total)) weights in + let total = List.fold_left ( + ) 0 weights in + let rest = quantity' - total in + assert (rest >= 0); + let out = match weights with [] -> [] | hd :: tl -> (hd + rest) :: tl in + let retotal = List.fold_left ( + ) 0 out in + assert (retotal = quantity'); + out + +let rec make_paths ~config ~depth ~quantity ~path acc = + assert (quantity > 0); + if quantity = 1 then (path, make_contents config) :: acc + else if depth = 0 then + let children = + List.init quantity (fun _ -> + let name = make_name config in + let path = name :: path in + (path, make_contents config)) + in + List.rev_append children acc + else + let depth = depth - 1 in + List.fold_left + (fun acc quantity -> + let name = make_name config in + let path = name :: path in + make_paths ~config ~depth ~quantity ~path acc) + acc + (make_balanced config quantity) + +let array_shuffle arr = + for i = 0 to Array.length arr - 1 do + let j = Random.int (Array.length arr - i) in + let tmp = arr.(i) in + arr.(i) <- arr.(j); + arr.(j) <- tmp + done + +let make_paths ?(path = []) ~config () = + let q0 = config.elements in + let q1 = if config.nb_adds <= 0 then q0 else 2 * q0 in + let all = make_paths ~config ~depth:config.max_depth ~quantity:q1 ~path [] in + let all = Array.of_list all in + let all = Array.map (fun (path, contents) -> (List.rev path, contents)) all in + array_shuffle all; + let init = min (Array.length all) q0 in + (Array.sub all 0 init, Array.sub all init (Array.length all - init)) + +let random_sample nb arr = + Array.init nb (fun _ -> arr.(Random.int (Array.length arr))) + +let make_task ~config paths add_paths = + let to_find = + Array.map (fun (name, _) -> Find name) + @@ random_sample config.nb_finds paths + in + let to_rem = + Array.map (fun (name, _) -> Rem name) @@ random_sample config.nb_rems paths + in + let to_add = + Array.map (fun (name, contents) -> Add (name, contents)) + @@ random_sample config.nb_adds add_paths + in + let task = Array.concat [ to_find; to_add; to_rem ] in + array_shuffle task; + task + +let make ~config = + let paths, add_paths = make_paths ~config () in + let tasks = + Array.init config.nb_tasks (fun _ -> make_task ~config paths add_paths) + in + (paths, tasks) + +let make_full ~config = + let subtree_config = + { config with elements = config.elements / config.nb_tasks; nb_tasks = 1 } + in + let sub = + List.init config.nb_tasks (fun i -> + let i = string_of_int i in + let paths, add_paths = + make_paths ~path:[ i ] ~config:subtree_config () + in + let task = make_task ~config:subtree_config paths add_paths in + (paths, task)) + in + let paths = Array.concat @@ List.map fst sub in + let tasks = Array.of_list @@ List.map snd sub in + (paths, tasks) diff --git a/test/irmin-pack/bench_multicore/main.ml b/test/irmin-pack/bench_multicore/main.ml new file mode 100644 index 0000000000..1b53002356 --- /dev/null +++ b/test/irmin-pack/bench_multicore/main.ml @@ -0,0 +1,147 @@ +let () = Random.init 0 + +let range = + let parse str = + try Scanf.sscanf str "%i-%i" (fun x y -> `Ok (x, y)) + with End_of_file -> ( + try Scanf.sscanf str "%i" (fun x -> `Ok (x, x)) + with End_of_file -> `Error ("not a range: " ^ str)) + in + let print h (x, y) = + if x = y then Format.fprintf h "%i" x else Format.fprintf h "%i-%i" x y + in + (parse, print) + +let elements = + Cmdliner.Arg.( + value + & opt int 500_000 + & info [ "elements" ] ~docv:"ELEMENTS" ~doc:"Number of leaves in the tree") + +let nb_tasks = + Cmdliner.Arg.( + value + & opt int 10_000 + & info [ "tasks" ] ~docv:"TASKS" ~doc:"Number of tasks") + +let nb_finds = + Cmdliner.Arg.( + value + & opt int 33 + & info [ "finds" ] ~docv:"FINDS" ~doc:"Number of Tree.find queries per task") + +let nb_adds = + Cmdliner.Arg.( + value + & opt int 33 + & info [ "adds" ] ~docv:"ADDS" ~doc:"Number of Tree.add operations per task") + +let nb_rems = + Cmdliner.Arg.( + value + & opt int 33 + & info [ "rems" ] ~docv:"REMS" + ~doc:"Number of Tree.remove operations per task") + +let nb_runs = + Cmdliner.Arg.( + value + & opt int 10 + & info [ "runs" ] ~docv:"RUNS" ~doc:"Repeat benchmark N times") + +let branching = + Cmdliner.Arg.( + value + & opt range (1, 10_000) + & info [ "branch" ] ~docv:"BRANCH" ~doc:"Node branching factor") + +let balance = + Cmdliner.Arg.( + value + & opt range (1, 10_000) + & info [ "balance" ] ~docv:"BALANCE" ~doc:"Node branching balance") + +let name_length = + Cmdliner.Arg.( + value + & opt range (10, 256) + & info [ "name-length" ] ~docv:"NAME_LENGTH" ~doc:"Name length") + +let contents_length = + Cmdliner.Arg.( + value + & opt range (10, 1000) + & info [ "contents-length" ] ~docv:"CONTENTS_LENGTH" ~doc:"Contents length") + +let max_depth = + Cmdliner.Arg.( + value + & opt int 200 + & info [ "height" ] ~docv:"HEIGHT" ~doc:"Tree max height") + +let warm = + Cmdliner.Arg.( + value + & flag + & info [ "warm" ] ~docv:"WARM" ~doc:"Warm up the tree in memory") + +let config warm elements max_depth branching balance contents_length name_length + nb_tasks nb_finds nb_adds nb_rems nb_runs = + { + Gen.warm; + elements; + max_depth; + branching; + balance; + contents_length; + name_length; + nb_tasks; + nb_finds; + nb_adds; + nb_rems; + nb_runs; + } + +let config = + Cmdliner.Term.( + const config + $ warm + $ elements + $ max_depth + $ branching + $ balance + $ contents_length + $ name_length + $ nb_tasks + $ nb_finds + $ nb_adds + $ nb_rems + $ nb_runs) + +let bench_half config = + Logs.set_level None; + Eio_main.run @@ fun env -> Bench.half ~d_mgr:env#domain_mgr ~config + +let bench_full config = + Logs.set_level None; + Eio_main.run @@ fun env -> Bench.full ~d_mgr:env#domain_mgr ~config + +let cmd_half = + let doc = "Half-diamond benchmark" in + Cmdliner.Cmd.v + (Cmdliner.Cmd.info "half" ~doc) + Cmdliner.Term.(const bench_half $ config) + +let cmd_full = + let doc = "Full-diamond benchmark" in + Cmdliner.Cmd.v + (Cmdliner.Cmd.info "full" ~doc) + Cmdliner.Term.(const bench_full $ config) + +let cmds = [ cmd_half; cmd_full ] + +let default_cmd = + let doc = "Irmin multicore benchmarks" in + Cmdliner.Cmd.info "help" ~doc + +let () = Stdlib.exit @@ Cmdliner.Cmd.eval @@ Cmdliner.Cmd.group default_cmd cmds diff --git a/test/irmin-pack/bench_multicore/workers.ml b/test/irmin-pack/bench_multicore/workers.ml new file mode 100644 index 0000000000..75cad41c20 --- /dev/null +++ b/test/irmin-pack/bench_multicore/workers.ml @@ -0,0 +1,35 @@ +let run ~d_mgr ~nb ?(finally = Fun.id) tasks = + let sem = Eio.Semaphore.make 0 in + let at = Atomic.make 0 in + let worker () = + Eio.Semaphore.acquire sem; + let rec go ~count () = + let i = Atomic.fetch_and_add at 1 in + if i >= Array.length tasks then ( (* Format.printf "did %#i@." count; *) ) + else + let task = tasks.(i) in + task (); + go ~count:(count + 1) () + in + go ~count:0 () + in + Eio.Switch.run @@ fun sw -> + let fibers = + worker + :: List.init (nb - 1) (fun _ -> + let mut = Eio.Semaphore.make 0 in + ( Eio.Fiber.fork ~sw @@ fun () -> + Eio.Domain_manager.run d_mgr @@ fun () -> + worker (); + Eio.Semaphore.release mut ); + fun () -> Eio.Semaphore.acquire mut) + in + let t0 = Unix.gettimeofday () in + for _ = 1 to nb do + Eio.Semaphore.release sem + done; + Eio.Fiber.all fibers; + finally (); + let t1 = Unix.gettimeofday () in + let elapsed = 1000.0 *. (t1 -. t0) in + elapsed From 5b9c00264cccff7ac9d827f305b6519a46ff00d9 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Mon, 10 Jul 2023 12:49:41 +0200 Subject: [PATCH 67/99] Optimize Tree findv_cache for add/remove --- src/irmin/tree.ml | 25 ++++++++++++++++++------- 1 file changed, 18 insertions(+), 7 deletions(-) diff --git a/src/irmin/tree.ml b/src/irmin/tree.ml index 43fbd3278a..ba353e7cd3 100644 --- a/src/irmin/tree.ml +++ b/src/irmin/tree.ml @@ -563,7 +563,7 @@ module Make (P : Backend.S) = struct Portable_dirty (v, m)) |> sealv - let of_v ?length ~env v = + let of_v ?length ?findv_cache ~env v = let ptr, map, value = match v with | Map m -> (Ptr_none, Some m, None) @@ -574,7 +574,7 @@ module Make (P : Backend.S) = struct let ptr = Atomic.make ptr in let map = Atomic.make map in let value = Atomic.make value in - let findv_cache = Atomic.make None in + let findv_cache = Atomic.make findv_cache in let length = match length with None -> Lazy_cache.unknown () | Some len -> len in @@ -585,10 +585,12 @@ module Make (P : Backend.S) = struct let of_map m = of_v (Map m) let of_key repo k = of_v (Key (repo, k)) - let of_value ?length ?updates repo v = - of_v ?length (Value (repo, v, updates)) + let of_value ?length ?findv_cache ?updates repo v = + of_v ?length ?findv_cache (Value (repo, v, updates)) + + let of_portable_dirty ?findv_cache ~env p updates = + of_v ?findv_cache ~env (Portable_dirty (p, updates)) - let of_portable_dirty p updates = of_v (Portable_dirty (p, updates)) let pruned h = of_v (Pruned h) let info_is_empty i = @@ -1606,6 +1608,11 @@ module Make (P : Backend.S) = struct | Remove when exists -> len - 1 | _ -> len)) + let clear_findv_cache t step = + match Atomic.get t.info.findv_cache with + | None -> None + | Some m -> Some (StepMap.remove step m) + let update t step up = let env = t.info.env in let of_map m = @@ -1621,11 +1628,15 @@ module Make (P : Backend.S) = struct if updates == updates' then t else let length = incremental_length t step up n updates in - of_value ?length ~env repo n ~updates:updates' + let findv_cache = clear_findv_cache t step in + of_value ?length ?findv_cache ~env repo n ~updates:updates' in let of_portable n updates = let updates' = StepMap.add step up updates in - if updates == updates' then t else of_portable_dirty ~env n updates' + if updates == updates' then t + else + let findv_cache = clear_findv_cache t step in + of_portable_dirty ?findv_cache ~env n updates' in match (Scan.cascade t From a1150e83a476f0c44b6ab1b359e3a00434b67a24 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Mon, 10 Jul 2023 12:51:18 +0200 Subject: [PATCH 68/99] Fix formatting and remove old tests --- src/irmin-pack/unix/async.ml | 12 ++--- src/irmin/backend.ml | 3 +- test/irmin-pack/test_multicore.ml | 85 ++++++++++++++++++------------- test/multirmin/dune | 3 -- test/multirmin/test.ml | 75 --------------------------- 5 files changed, 57 insertions(+), 121 deletions(-) delete mode 100644 test/multirmin/dune delete mode 100644 test/multirmin/test.ml diff --git a/src/irmin-pack/unix/async.ml b/src/irmin-pack/unix/async.ml index f843f42abe..4c83400ecc 100644 --- a/src/irmin-pack/unix/async.ml +++ b/src/irmin-pack/unix/async.ml @@ -31,19 +31,17 @@ module Unix = struct let rec add pid = let pids = Atomic.get proc_list in - if not (Atomic.compare_and_set proc_list pids (pid :: pids)) - then add pid + if not (Atomic.compare_and_set proc_list pids (pid :: pids)) then add pid let rec remove pid = let pids = Atomic.get proc_list in - let new_pids = List.filter (fun pid' -> pid <> pid') pids in - if not (Atomic.compare_and_set proc_list pids new_pids) - then remove pid + let new_pids = List.filter (fun pid' -> pid <> pid') pids in + if not (Atomic.compare_and_set proc_list pids new_pids) then remove pid let () = at_exit @@ fun () -> - let pids = Atomic.exchange proc_list [] in - List.iter kill_no_err pids + let pids = Atomic.exchange proc_list [] in + List.iter kill_no_err pids end type outcome = [ `Success | `Cancelled | `Failure of string ] diff --git a/src/irmin/backend.ml b/src/irmin/backend.ml index 97cef5d19a..d56e9fa7e3 100644 --- a/src/irmin/backend.ml +++ b/src/irmin/backend.ml @@ -98,7 +98,8 @@ module type S = sig val config : t -> Conf.t val batch : - ?lock:bool -> t -> + ?lock:bool -> + t -> (read_write Contents.t -> read_write Node.t -> read_write Commit.t -> 'a) -> 'a (** A getter from repo to backend stores in rw mode. *) diff --git a/test/irmin-pack/test_multicore.ml b/test/irmin-pack/test_multicore.ml index 4a7112bc1f..a93518bd00 100644 --- a/test/irmin-pack/test_multicore.ml +++ b/test/irmin-pack/test_multicore.ml @@ -96,7 +96,9 @@ let make_tree shape = let rec list_shape acc path : shape -> _ = function | `Contents _c -> (List.rev path, []) :: acc | `Node children -> - let l = List.map (fun (name, child) -> (name, make_tree child)) children in + let l = + List.map (fun (name, child) -> (name, make_tree child)) children + in let acc = (List.rev path, l) :: acc in List.fold_left (fun acc (name, child) -> list_shape acc (name :: path) child) @@ -315,15 +317,16 @@ let test_hash d_mgr = let list_all cache tree paths = List.iter - (fun (path, expected) -> - let value = Store.Tree.list ~cache tree path in - assert (List.length expected = List.length value); - List.iter (fun (s, t) -> - let t' = List.assoc s value in - let diffs = Store.Tree.diff t t' in - assert (diffs = []) - ) expected) - paths + (fun (path, expected) -> + let value = Store.Tree.list ~cache tree path in + assert (List.length expected = List.length value); + List.iter + (fun (s, t) -> + let t' = List.assoc s value in + let diffs = Store.Tree.diff t t' in + assert (diffs = [])) + expected) + paths let test_list_disk ~cache d_mgr = Logs.set_level None; @@ -356,31 +359,37 @@ let test_commit_of_hash d_mgr = let hash1 = Store.Commit.hash commit1 in let tree1 = Store.Commit.tree commit1 in List.iter - (fun op -> - let tree = Store.Commit.tree commit1 in - let tree = apply_op tree op in - Store.set_tree_exn ~info store [] tree) - patch01; + (fun op -> + let tree = Store.Commit.tree commit1 in + let tree = apply_op tree op in + Store.set_tree_exn ~info store [] tree) + patch01; let commit2 = Store.Head.get store in let hash2 = Store.Commit.hash commit2 in let tree2 = Store.Commit.tree commit2 in List.iter - (fun op -> - let tree = Store.Commit.tree commit2 in - let tree = apply_op tree op in - Store.set_tree_exn ~info store [] tree) - patch02; + (fun op -> + let tree = Store.Commit.tree commit2 in + let tree = apply_op tree op in + Store.set_tree_exn ~info store [] tree) + patch02; let commit3 = Store.Head.get store in let hash3 = Store.Commit.hash commit3 in let tree3 = Store.Commit.tree commit3 in let do_commit_of_hash () = - let t1 = Store.Commit.of_hash repo hash1 |> Option.get |> Store.Commit.tree in + let t1 = + Store.Commit.of_hash repo hash1 |> Option.get |> Store.Commit.tree + in let diffs = Store.Tree.diff tree1 t1 in assert (diffs = []); - let t2 = Store.Commit.of_hash repo hash2 |> Option.get |> Store.Commit.tree in + let t2 = + Store.Commit.of_hash repo hash2 |> Option.get |> Store.Commit.tree + in let diffs = Store.Tree.diff tree2 t2 in assert (diffs = []); - let t3 = Store.Commit.of_hash repo hash3 |> Option.get |> Store.Commit.tree in + let t3 = + Store.Commit.of_hash repo hash3 |> Option.get |> Store.Commit.tree + in let diffs = Store.Tree.diff tree3 t3 in assert (diffs = []) in @@ -396,20 +405,22 @@ let test_commit_parents d_mgr = let commit = Store.Head.get store in let tree = Store.Commit.tree commit in let commits = - snd @@ List.fold_left_map - (fun tree op -> - let tree = apply_op tree op in - Store.set_tree_exn ~info store [] tree; - tree, Store.Head.get store) tree patch01 + snd + @@ List.fold_left_map + (fun tree op -> + let tree = apply_op tree op in + Store.set_tree_exn ~info store [] tree; + (tree, Store.Head.get store)) + tree patch01 in let do_commit_parents () = ignore (List.fold_left - (fun parent commit -> - let parents = Store.Commit.parents commit in - assert (parents = [Store.Commit.key parent]); - commit) - commit commits) + (fun parent commit -> + let parents = Store.Commit.parents commit in + assert (parents = [ Store.Commit.key parent ]); + commit) + commit commits) in domains_spawn d_mgr do_commit_parents; Store.Repo.close repo @@ -423,13 +434,17 @@ let test_commit_v d_mgr = let commit = Store.Head.get store in let tree = List.fold_left apply_op (Store.Commit.tree commit) patch01 in let do_commit_v () = - let _ = Store.Commit.v repo ~info:(info ()) ~parents:[Store.Commit.key commit] tree in + let _ = + Store.Commit.v repo ~info:(info ()) + ~parents:[ Store.Commit.key commit ] + tree + in () in domains_spawn d_mgr do_commit_v; Store.Repo.close repo - let tests d_mgr = +let tests d_mgr = let tc name fn = Alcotest.test_case name `Quick (fun () -> fn d_mgr) in [ tc "find." test_find; diff --git a/test/multirmin/dune b/test/multirmin/dune deleted file mode 100644 index e413b02b4d..0000000000 --- a/test/multirmin/dune +++ /dev/null @@ -1,3 +0,0 @@ -(executable - (name test) - (libraries irmin irmin-test eio_main test_pack)) diff --git a/test/multirmin/test.ml b/test/multirmin/test.ml deleted file mode 100644 index 504eea4a50..0000000000 --- a/test/multirmin/test.ml +++ /dev/null @@ -1,75 +0,0 @@ -open Common - -let root = Filename.concat "_build" "test-readonly" - -module S = struct - module Maker = Irmin_pack_unix.Maker (Conf) - include Maker.Make (Schema) -end - -let config ?(readonly = false) ?(fresh = true) root = - Irmin_pack.config ~readonly ?index_log_size ~fresh root - -let info () = S.Info.empty - -let test_find repo i = - let tree = - repo - |> S.main - |> S.Head.get - |> S.Commit.hash - |> S.Commit.of_hash repo - |> Option.get - |> S.Commit.tree - in - let start_value = S.Tree.find tree [ "start" ] in - assert (start_value = Some "content-start"); - let str_i = string_of_int i in - let value = S.Tree.find tree [ str_i ] in - if not (value = Some ("content-" ^ str_i)) then - Format.printf "Couldn't read correct value from thread %d@." i - -let test_add repo i = - let main = S.main repo in - let tree = - main - |> S.Head.get - |> S.Commit.hash - |> S.Commit.of_hash repo - |> Option.get - |> S.Commit.tree - in - let str_i = string_of_int i in - let tree' = S.Tree.add tree [ str_i ] ("content-" ^ str_i) in - S.set_tree_exn ~info main [] tree'; - () - -let repeatedly_do fn arg () = - for _ = 0 to 100 do - Sys.opaque_identity (fn arg) - done - -let dispatch repo i () = - repeatedly_do - (if i mod 2 = 0 then (* Readers *) - test_find repo - else (* Writers *) test_add repo) - (i / 2) () - -let setup d_mgr = - rm_dir root; - let repo = S.Repo.v (config ~readonly:false ~fresh:true root) in - let main = S.main repo in - let init = S.Tree.singleton [ "start" ] "content-start" in - S.set_tree_exn ~parents:[] ~info main [] init; - S.Repo.close repo; - let repo = S.Repo.v (config ~readonly:false ~fresh:false root) in - let fibers = - List.init 7 (fun i () -> Eio.Domain_manager.run d_mgr (dispatch repo i)) - in - Eio.Fiber.all fibers; - S.Repo.close repo - -let () = - Logs.set_level None; - Eio_main.run @@ fun env -> setup env#domain_mgr From 54040457c6d93350b824c7592899282610e97999 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Wed, 12 Jul 2023 12:34:30 +0200 Subject: [PATCH 69/99] Fix irmin_fsck --- test/irmin-tezos/dune | 2 +- test/irmin-tezos/irmin_fsck.ml | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/test/irmin-tezos/dune b/test/irmin-tezos/dune index 63b30a4e56..e716cc75ef 100644 --- a/test/irmin-tezos/dune +++ b/test/irmin-tezos/dune @@ -1,7 +1,7 @@ (executable (name irmin_fsck) (modules irmin_fsck) - (libraries irmin-pack irmin-pack.unix irmin-tezos)) + (libraries irmin-pack irmin-pack.unix irmin-tezos eio_main)) (executable (name generate) diff --git a/test/irmin-tezos/irmin_fsck.ml b/test/irmin-tezos/irmin_fsck.ml index ac0be32364..a3dd4841d9 100644 --- a/test/irmin-tezos/irmin_fsck.ml +++ b/test/irmin-tezos/irmin_fsck.ml @@ -31,6 +31,7 @@ end module Store_tz = Irmin_pack_unix.Checks.Make (Maker_tz) let () = + Eio_main.run @@ fun _ -> try let store_type = Sys.getenv "STORE" in if store_type = "PACK" then match Store.cli () with _ -> . From 734d6e24b8d1563645365fc6198b07456bb46f41 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Wed, 12 Jul 2023 14:33:22 +0200 Subject: [PATCH 70/99] Fix opam dependencies --- irmin-cli.opam | 2 ++ irmin-fs.opam | 1 + irmin-pack-tools.opam | 9 +++++++++ irmin-pack.opam | 2 +- irmin-test.opam | 10 ++++++++++ irmin.opam | 1 + libirmin.opam | 2 ++ 7 files changed, 26 insertions(+), 1 deletion(-) diff --git a/irmin-cli.opam b/irmin-cli.opam index 46776f98df..16640f162a 100644 --- a/irmin-cli.opam +++ b/irmin-cli.opam @@ -46,6 +46,8 @@ depends: [ "fmt" "git" {>= "3.7.0"} "happy-eyeballs-lwt" + "eio_main" {>= "0.10"} + "lwt_eio" {>= "0.3"} "lwt" {>= "5.3.0"} "irmin-test" {with-test & = version} "alcotest" {with-test} diff --git a/irmin-fs.opam b/irmin-fs.opam index b31298375d..fd7cca7a34 100644 --- a/irmin-fs.opam +++ b/irmin-fs.opam @@ -19,6 +19,7 @@ depends: [ "irmin" {= version} "astring" "logs" + "eio" {>= "0.10"} "lwt" {>= "5.3.0"} "alcotest" {with-test} "irmin-test" {with-test & = version} diff --git a/irmin-pack-tools.opam b/irmin-pack-tools.opam index 31d1a332e8..18160121ed 100644 --- a/irmin-pack-tools.opam +++ b/irmin-pack-tools.opam @@ -25,6 +25,7 @@ depends: [ "cmdliner" {>= "1.1.0"} "cmdliner" {>= "1.1.0"} "notty" {>= "0.2.3"} + "index" {>= "dev"} "ppx_repr" {>= "0.7.0"} "ptime" "hex" @@ -32,6 +33,14 @@ depends: [ "alcotest" {with-test} ] +pin-depends: [ + # Needed by Index + [ "terminal.dev" "git+https://github.com/craigfe/progress#76e7c791bd17c28b3e605d9c383102a30345e029" ] + [ "progress.dev" "git+https://github.com/craigfe/progress#76e7c791bd17c28b3e605d9c383102a30345e029" ] + # Needed by Irmin-pack + [ "index.dev" "git+https://github.com/patricoferris/index#cfa32e984b633d08b2f0c1fc1f792925c6d74f8e" ] +] + synopsis: "Utils for Irmin-pack" description: """ `Irmin-pack-tools` defines useful binaries and libraries for diff --git a/irmin-pack.opam b/irmin-pack.opam index 81f2b3e092..c75df5320f 100644 --- a/irmin-pack.opam +++ b/irmin-pack.opam @@ -20,7 +20,7 @@ depends: [ "index" {= "dev"} "fmt" "logs" - "lwt" {>= "5.4.0"} + "eio" {>= "0.10"} "mtime" {>= "2.0.0"} "cmdliner" "optint" {>= "0.1.0"} diff --git a/irmin-test.opam b/irmin-test.opam index 230a1e551a..150b0c009d 100644 --- a/irmin-test.opam +++ b/irmin-test.opam @@ -23,6 +23,10 @@ depends: [ "jsonm" "logs" "lwt" {>= "5.3.0"} + "eio" {>= "0.10"} + "eio_main" {>= "0.10"} + "alcotest" {>= "dev"} + "qcheck-alcotest" {with-test & >= "0.21.1"} "metrics-unix" "ocaml-syntax-shims" "cmdliner" @@ -33,6 +37,12 @@ depends: [ "qcheck-alcotest" {>= "0.21.1" & with-test} ] +pin-depends: [ + # Fix race in formatters + [ "alcotest.dev" "git+https://github.com/haesbaert/alcotest#99030be1df12a17fc2a0f3d00b181cd31cf6b0d4" ] + [ "alcotest-lwt.dev" "git+https://github.com/haesbaert/alcotest#99030be1df12a17fc2a0f3d00b181cd31cf6b0d4" ] +] + synopsis: "Irmin test suite" description: """ `irmin-test` provides access to the Irmin test suite for testing storage backend diff --git a/irmin.opam b/irmin.opam index 2567091534..4c58a2bc73 100644 --- a/irmin.opam +++ b/irmin.opam @@ -22,6 +22,7 @@ depends: [ "uutf" "jsonm" {>= "1.0.0"} "eio" {>= "0.6"} + "lwt" {>= "5.6.1"} "digestif" {>= "0.9.0"} "ocamlgraph" "logs" {>= "0.5.0"} diff --git a/libirmin.opam b/libirmin.opam index 76c709512c..b7953ffd94 100644 --- a/libirmin.opam +++ b/libirmin.opam @@ -12,6 +12,8 @@ depends: [ "ctypes-foreign" {>= "0.18"} "irmin" {= version} "irmin-cli" {= version} + "eio_main" {>= "0.10"} + "lwt_eio" {>= "0.3"} ] build: [ ["dune" "subst"] {dev} From 1b959e930d204d43dc8eb4f00dd5ffbcb1ddf342 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Thu, 24 Aug 2023 14:16:50 +0200 Subject: [PATCH 71/99] eio: irmin-server using lwt_eio --- examples/server/client.ml | 37 ++-- examples/server/server.ml | 10 +- src/irmin-client/client.ml | 145 ++++++++-------- src/irmin-client/client_intf.ml | 16 +- src/irmin-client/unix/bin/client.ml | 259 ++++++++++++++-------------- src/irmin-server/command.ml | 149 ++++++++++------ src/irmin-server/dune | 2 +- src/irmin-server/unix/server.ml | 54 +++--- test/irmin-client/test.ml | 76 ++++---- test/irmin-client/util.ml | 2 +- 10 files changed, 384 insertions(+), 366 deletions(-) diff --git a/examples/server/client.ml b/examples/server/client.ml index 41106a36cc..742e318ce0 100644 --- a/examples/server/client.ml +++ b/examples/server/client.ml @@ -14,8 +14,6 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Lwt.Syntax - module Client = Irmin_client_unix.Make_codec (Irmin_server.Conn.Codec.Bin) (Config.Store) @@ -24,15 +22,11 @@ module Info = Irmin_client_unix.Info (Client.Info) let info msg = Info.v ~author:"tester" msg let main () = - let* client = Client.connect Config.uri in - let* main = Client.main client in - let* () = - Client.set_exn ~info:(info "set testing") main [ "testing" ] "testing" - in - let* () = - Client.set_exn ~info:(info "set remove") main [ "remove" ] "remove" - in - let* () = Client.remove_exn ~info:(info "remove remove") main [ "remove" ] in + let client = Client.connect Config.uri in + let main = Client.main client in + Client.set_exn ~info:(info "set testing") main [ "testing" ] "testing"; + Client.set_exn ~info:(info "set remove") main [ "remove" ] "remove"; + Client.remove_exn ~info:(info "remove remove") main [ "remove" ]; let batch = Client.Batch.( v () @@ -40,33 +34,32 @@ let main () = |> add_value [ "foo" ] "bar" |> remove [ "testing" ]) in - let* c = Client.Batch.apply ~info:(info "apply batch") ~path:[] main batch in + let c = Client.Batch.apply ~info:(info "apply batch") ~path:[] main batch in Logs.info (fun l -> l "Applied batch -> commit %a" Irmin.Type.(pp Client.commit_key_t) c); - let* abc = Client.get main [ "a"; "b"; "c" ] in + let abc = Client.get main [ "a"; "b"; "c" ] in assert (String.equal abc "123"); - let* foo = Client.get main [ "foo" ] in + let foo = Client.get main [ "foo" ] in assert (foo = "bar"); - let* testing = Client.find main [ "testing" ] in + let testing = Client.find main [ "testing" ] in assert (Option.is_none testing); - let* remove = Client.mem main [ "remove" ] in + let remove = Client.mem main [ "remove" ] in assert (remove = false); - let* commit = Client.Commit.of_key client c in + let commit = Client.Commit.of_key client c in let tree = Client.Commit.tree (Option.get commit) in - let* concrete = Client.Tree.to_concrete tree in - - Logs.info (fun l -> l "%a" Irmin.Type.(pp Client.Tree.concrete_t) concrete); + let concrete = Client.Tree.to_concrete tree in - Lwt.return_unit + Logs.info (fun l -> l "%a" Irmin.Type.(pp Client.Tree.concrete_t) concrete) let () = Fmt_tty.setup_std_outputs (); Logs.(set_level @@ Some Debug); Irmin.Export_for_backends.Logging.reporter (module Mtime_clock) |> Logs.set_reporter; - Lwt_main.run @@ main () + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> main () diff --git a/examples/server/server.ml b/examples/server/server.ml index 0856e791ae..2f51c71ea4 100644 --- a/examples/server/server.ml +++ b/examples/server/server.ml @@ -23,13 +23,11 @@ let main () = let config = Irmin_mem.config () in let dashboard = `TCP (`Port 1234) in let uri = Config.uri in + Lwt_eio.run_lwt @@ fun () -> let* server = Server.v ~uri ~dashboard config in - Logs.debug (fun l -> l "Listening on %a@." Uri.pp uri); + Format.printf "Listening on %a@." Uri.pp uri; Server.serve server let () = - Fmt_tty.setup_std_outputs (); - Logs.(set_level @@ Some Debug); - Irmin.Export_for_backends.Logging.reporter (module Mtime_clock) - |> Logs.set_reporter; - Lwt_main.run @@ main () + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> main () diff --git a/src/irmin-client/client.ml b/src/irmin-client/client.ml index 38a561fae1..6e94f75c3d 100644 --- a/src/irmin-client/client.ml +++ b/src/irmin-client/client.ml @@ -109,7 +109,7 @@ struct [%log.debug "Completed request: command=%s" name]; x - let request (t : t) (type x y) + let request_lwt (t : t) (type x y) (module Cmd : C.CMD with type res = x and type req = y) (a : y) = if t.closed then raise Irmin.Closed else @@ -121,6 +121,8 @@ struct let* () = IO.flush t.conn.oc in recv t name Cmd.res_t) + let request t cmd a = Lwt_eio.run_lwt @@ fun () -> request_lwt t cmd a + let recv_branch_diff (t : t) = let* _status = Conn.Response.read_header t.conn in Conn.read t.conn @@ -140,6 +142,7 @@ struct module Conn = Command.Conn module Commands = Command.Commands + let request_lwt = Client.request_lwt let request = Client.request let rec connect ?ctx config = @@ -185,32 +188,32 @@ struct type value = Val.t type hash = Hash.t - let mem t key = request t (module Mem) key >|= Error.unwrap "Contents.mem" + let mem t key = request t (module Mem) key |> Error.unwrap "Contents.mem" let find t key = - request t (module Find) key >|= Error.unwrap "Contents.find" + request t (module Find) key |> Error.unwrap "Contents.find" let add t value = - request t (module Add) value >|= Error.unwrap "Contents.add" + request t (module Add) value |> Error.unwrap "Contents.add" let unsafe_add t key value = request t (module Unsafe_add) (key, value) - >|= Error.unwrap "Contents.unsafe_add" + |> Error.unwrap "Contents.unsafe_add" let index t hash = - request t (module Index) hash >|= Error.unwrap "Contents.index" + request t (module Index) hash |> Error.unwrap "Contents.index" let batch t f = f t - let close t = Client.close t + let close t = Lwt_eio.run_lwt @@ fun () -> Client.close t let merge t = let f ~old a b = - let* old = old () in + let old = old () in match old with | Ok old -> request t (module Merge) (old, a, b) - >|= Error.unwrap "Contents.merge" - | Error e -> Lwt.return_error e + |> Error.unwrap "Contents.merge" + | Error e -> Error e in Irmin.Merge.v Irmin.Type.(option Key.t) f end @@ -230,27 +233,27 @@ struct type value = Val.t type hash = Hash.t - let mem t key = request t (module Mem) key >|= Error.unwrap "Node.mem" - let find t key = request t (module Find) key >|= Error.unwrap "Node.find" - let add t value = request t (module Add) value >|= Error.unwrap "Node.add" + let mem t key = request t (module Mem) key |> Error.unwrap "Node.mem" + let find t key = request t (module Find) key |> Error.unwrap "Node.find" + let add t value = request t (module Add) value |> Error.unwrap "Node.add" let unsafe_add t key value = request t (module Unsafe_add) (key, value) - >|= Error.unwrap "Node.unsafe_add" + |> Error.unwrap "Node.unsafe_add" let index t hash = - request t (module Index) hash >|= Error.unwrap "Node.index" + request t (module Index) hash |> Error.unwrap "Node.index" let batch t f = f t - let close t = Client.close t + let close t = Lwt_eio.run_lwt @@ fun () -> Client.close t let merge t = let f ~old a b = - let* old = old () in + let old = old () in match old with | Ok old -> - request t (module Merge) (old, a, b) >|= Error.unwrap "Node.merge" - | Error e -> Lwt.return_error e + request t (module Merge) (old, a, b) |> Error.unwrap "Node.merge" + | Error e -> Error e in Irmin.Merge.v Irmin.Type.(option Key.t) f end @@ -271,32 +274,30 @@ struct type value = Val.t type hash = Hash.t - let mem t key = request t (module Mem) key >|= Error.unwrap "Commit.mem" - - let find t key = - request t (module Find) key >|= Error.unwrap "Commit.find" + let mem t key = request t (module Mem) key |> Error.unwrap "Commit.mem" + let find t key = request t (module Find) key |> Error.unwrap "Commit.find" let add t value = - request t (module Add) value >|= Error.unwrap "Commit.add" + request t (module Add) value |> Error.unwrap "Commit.add" let unsafe_add t key value = request t (module Unsafe_add) (key, value) - >|= Error.unwrap "Commit.unsafe_add" + |> Error.unwrap "Commit.unsafe_add" let index t hash = - request t (module Index) hash >|= Error.unwrap "Commit.index" + request t (module Index) hash |> Error.unwrap "Commit.index" let batch t f = f t - let close t = Client.close t + let close t = Lwt_eio.run_lwt @@ fun () -> Client.close t let merge t ~info = let f ~old a b = - let* old = old () in + let old = old () in match old with | Ok old -> request t (module Merge) (info (), (old, a, b)) - >|= Error.unwrap "Node.merge" - | Error e -> Lwt.return_error e + |> Error.unwrap "Node.merge" + | Error e -> Error e in Irmin.Merge.v Irmin.Type.(option Key.t) f end @@ -313,29 +314,29 @@ struct type key = Key.t type value = Val.t - let mem t key = request t (module Mem) key >|= Error.unwrap "Branch.mem" - - let find t key = - request t (module Find) key >|= Error.unwrap "Branch.find" + let mem t key = request t (module Mem) key |> Error.unwrap "Branch.mem" + let find t key = request t (module Find) key |> Error.unwrap "Branch.find" let set t key value = - request t (module Set) (key, value) >|= Error.unwrap "Branch.set" + request t (module Set) (key, value) |> Error.unwrap "Branch.set" let test_and_set t key ~test ~set = request t (module Test_and_set) (key, test, set) - >|= Error.unwrap "Branch.test_and_set" + |> Error.unwrap "Branch.test_and_set" let remove t key = - request t (module Remove) key >|= Error.unwrap "Branch.remove" + request t (module Remove) key |> Error.unwrap "Branch.remove" - let list t = request t (module List) () >|= Error.unwrap "Branch.list" + let list t = request t (module List) () |> Error.unwrap "Branch.list" type watch = t let watch t ?init f = + Lwt_eio.run_lwt @@ fun () -> + let f key diff = Lwt_eio.run_eio @@ fun () -> f key diff in let* t = dup t in let* () = - request t (module Watch) init >|= Error.unwrap "Branch.watch" + request_lwt t (module Watch) init >|= Error.unwrap "Branch.watch" in let rec loop () = if t.closed || Conn.is_closed t.conn then Lwt.return_unit @@ -352,9 +353,11 @@ struct Lwt.return t let watch_key t key ?init f = + Lwt_eio.run_lwt @@ fun () -> + let f x = Lwt_eio.run_eio @@ fun () -> f x in let* t = dup t in let* () = - request t (module Watch_key) (init, key) + request_lwt t (module Watch_key) (init, key) >|= Error.unwrap "Branch.watch_key" in let rec loop () = @@ -373,11 +376,12 @@ struct Lwt.return t let unwatch _t watch = + Lwt_eio.run_lwt @@ fun () -> let* () = Conn.write watch.Client.conn Unwatch.req_t () in Client.close watch - let clear t = request t (module Clear) () >|= Error.unwrap "Branch.clear" - let close t = Client.close t + let clear t = request t (module Clear) () |> Error.unwrap "Branch.clear" + let close t = Lwt_eio.run_lwt @@ fun () -> Client.close t end module Slice = Store.Backend.Slice @@ -385,14 +389,14 @@ struct module Repo = struct type nonrec t = Client.t - let v config = connect config + let v config = Lwt_eio.run_lwt @@ fun () -> connect config let config (t : t) = t.Client.config - let close (t : t) = Client.close t + let close (t : t) = Lwt_eio.run_lwt @@ fun () -> Client.close t let contents_t (t : t) = t let node_t (t : t) = t let commit_t (t : t) = t let branch_t (t : t) = t - let batch (t : t) f = f t t t + let batch ?lock:_ (t : t) f = f t t t end module Remote = Irmin.Backend.Remote.None (Commit.Key) (Store.Branch) @@ -403,12 +407,12 @@ struct let ping t = request t (module Commands.Ping) () let export ?depth t = - request t (module Commands.Export) depth >|= Error.unwrap "export" + request t (module Commands.Export) depth |> Error.unwrap "export" let import t slice = - request t (module Commands.Import) slice >|= Error.unwrap "import" + request t (module Commands.Import) slice |> Error.unwrap "import" - let close t = Client.close t + let close t = Lwt_eio.run_lwt @@ fun () -> Client.close t let connect ?tls ?hostname uri = let conf = config ?tls ?hostname uri in @@ -445,12 +449,12 @@ struct (path, `Contents (`Hash hash, metadata)) :: t let add_tree path tree t = - let+ tree = + let tree = match Tree.key tree with | None -> - let+ concrete_tree = Tree.to_concrete tree in + let concrete_tree = Tree.to_concrete tree in Request_tree.Concrete concrete_tree - | Some key -> Request_tree.Key key |> Lwt.return + | Some key -> Request_tree.Key key in (path, `Tree tree) :: t @@ -458,7 +462,7 @@ struct let repo = repo store in let store = request_store store in request repo (module Commands.Batch.Apply) ((store, path), info (), t) - >|= Error.unwrap "Batch.apply" + |> Error.unwrap "Batch.apply" end (* Overrides *) @@ -486,18 +490,17 @@ struct end let of_key repo key = - if Cache.Key.mem Cache.key key then - Lwt.return_some (Cache.Key.find Cache.key key) + if Cache.Key.mem Cache.key key then Some (Cache.Key.find Cache.key key) else - let+ x = of_key repo key in + let x = of_key repo key in Option.iter (Cache.Key.add Cache.key key) x; x let of_hash repo hash = if Cache.Hash.mem Cache.hash hash then - Lwt.return_some (Cache.Hash.find Cache.hash hash) + Some (Cache.Hash.find Cache.hash hash) else - let+ x = of_hash repo hash in + let x = of_hash repo hash in Option.iter (Cache.Hash.add Cache.hash hash) x; x end @@ -518,18 +521,18 @@ struct let of_hash repo hash = if Cache.Hash.mem Cache.hash hash then - Lwt.return_some (Cache.Hash.find Cache.hash hash) + Some (Cache.Hash.find Cache.hash hash) else - let+ x = of_hash repo hash in + let x = of_hash repo hash in Option.iter (Cache.Hash.add Cache.hash hash) x; x end let clone ~src ~dst = let repo = repo src in - let* repo = dup repo in - let* () = - Head.find src >>= function + let repo = Lwt_eio.run_lwt @@ fun () -> dup repo in + let () = + match Head.find src with | None -> Branch.remove repo dst | Some h -> Branch.set repo dst h in @@ -544,17 +547,17 @@ struct let mem store path = let repo = repo store in request repo (module Commands.Store.Mem) (request_store store, path) - >|= Error.unwrap "mem" + |> Error.unwrap "mem" let mem_tree store path = let repo = repo store in request repo (module Commands.Store.Mem_tree) (request_store store, path) - >|= Error.unwrap "mem_tree" + |> Error.unwrap "mem_tree" let find store path = let repo = repo store in request repo (module Commands.Store.Find) (request_store store, path) - >|= Error.unwrap "find" + |> Error.unwrap "find" let remove_exn ?clear ?retries ?allow_empty ?parents ~info store path = let parents = Option.map (List.map (fun c -> Commit.hash c)) parents in @@ -564,19 +567,17 @@ struct ( ((clear, retries), (allow_empty, parents)), (request_store store, path), info () ) - >|= Error.unwrap "remove" + |> Error.unwrap "remove" let remove ?clear ?retries ?allow_empty ?parents ~info store path = - let* x = - remove_exn ?clear ?retries ?allow_empty ?parents ~info store path - in - Lwt.return_ok x + let x = remove_exn ?clear ?retries ?allow_empty ?parents ~info store path in + Ok x let find_tree store path = let repo = repo store in - let+ concrete = + let concrete = request repo (module Commands.Store.Find_tree) (request_store store, path) - >|= Error.unwrap "find_tree" + |> Error.unwrap "find_tree" in Option.map Tree.of_concrete concrete end diff --git a/src/irmin-client/client_intf.ml b/src/irmin-client/client_intf.ml index 8b72bb5ef5..c2b2e777a5 100644 --- a/src/irmin-client/client_intf.ml +++ b/src/irmin-client/client_intf.ml @@ -35,24 +35,24 @@ end module type S = sig include Irmin.Generic_key.S - val connect : ?tls:bool -> ?hostname:string -> Uri.t -> repo Lwt.t + val connect : ?tls:bool -> ?hostname:string -> Uri.t -> repo val reconnect : repo -> unit Lwt.t val uri : repo -> Uri.t (** Get the URI the client is connected to *) - val close : repo -> unit Lwt.t + val close : repo -> unit (** Close connection to the server *) val dup : repo -> repo Lwt.t (** Duplicate a client. This will create a new connection with the same configuration *) - val ping : repo -> unit Error.result Lwt.t + val ping : repo -> unit Error.result (** Ping the server *) - val export : ?depth:int -> repo -> slice Lwt.t - val import : repo -> slice -> unit Lwt.t + val export : ?depth:int -> repo -> slice + val import : repo -> slice -> unit (** The batch API is used to have better control of when data is sent between the client and server when manipulating trees. *) @@ -70,7 +70,7 @@ module type S = sig (** A batch is list of updates and their associated paths *) val v : unit -> t - (** [val ()] creates a new batch *) + (** [v ()] creates a new batch *) val add_value : path -> ?metadata:metadata -> contents -> t -> t (** [add_value path ~metadata value batch] will add [value] at [path] with @@ -80,7 +80,7 @@ module type S = sig (** [add_hash path ~metadata hash batch] will add [hash] at [path] with associated [metadata] when [batch] is {!apply}'d *) - val add_tree : path -> tree -> t -> t Lwt.t + val add_tree : path -> tree -> t -> t (** [add_tree path batch] will add [tree] at [path] when [batch] is {!apply}'d @@ -90,7 +90,7 @@ module type S = sig val remove : path -> t -> t (** [remove path batch] will remove [path] when [batch] is {!apply}'d *) - val apply : info:Info.f -> ?path:path -> store -> t -> commit_key Lwt.t + val apply : info:Info.f -> ?path:path -> store -> t -> commit_key (** [apply ~info ~path store batch] applies [batch] to the subtree at [path] (defaults to the root) in [store]. The key of the commit is returned. *) end diff --git a/src/irmin-client/unix/bin/client.ml b/src/irmin-client/unix/bin/client.ml index ada841a345..e80a3cb11b 100644 --- a/src/irmin-client/unix/bin/client.ml +++ b/src/irmin-client/unix/bin/client.ml @@ -16,7 +16,6 @@ open Cmdliner open Lwt.Syntax -open Lwt.Infix open Import open Irmin_server @@ -36,9 +35,9 @@ let with_timer f = let t1 = Sys.time () -. t0 in (t1, a) -let init ~uri ~branch ~tls (module Client : Irmin_client.S) : client Lwt.t = - let* x = Client.Repo.v (Irmin_client.config ~tls uri) in - let+ x = +let init ~uri ~branch ~tls (module Client : Irmin_client.S) () : client = + let x = Client.Repo.v (Irmin_client.config ~tls uri) in + let x = match branch with | Some b -> Client.of_branch x @@ -47,21 +46,23 @@ let init ~uri ~branch ~tls (module Client : Irmin_client.S) : client Lwt.t = in S ((module Client : Irmin_client.S with type t = Client.t), x) -let run f time iterations = +let run f time iterations : unit = let rec eval iterations = if iterations = 0 then Lwt.return_unit else - let* () = f () in + let* () = Lwt_eio.run_eio f in eval (iterations - 1) in - let x = + let main () = if time then ( + Lwt_eio.run_lwt @@ fun () -> let+ n, x = with_timer (fun () -> eval iterations) in Logs.app (fun l -> l "Time: %fs" (n /. float_of_int iterations)); x) else f () in - Lwt_main.run x + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> main () let list_server_commands () = let module Store = Irmin_mem.KV.Make (Irmin.Contents.String) in @@ -79,149 +80,143 @@ let list_server_commands () = Cmd.commands let ping client = - run (fun () -> - client >>= fun (S ((module Client), client)) -> - let repo = Client.repo client in - let+ result = Client.ping repo in - let () = Error.unwrap "ping" result in - Logs.app (fun l -> l "OK")) + run @@ fun () -> + let (S ((module Client), client)) = client () in + let repo = Client.repo client in + let result = Client.ping repo in + let () = Error.unwrap "ping" result in + Logs.app (fun l -> l "OK") let find client path = - run (fun () -> - client >>= fun (S ((module Client), client)) -> - let path = - Irmin.Type.of_string Client.Path.t path |> Error.unwrap "path" - in - let* result = Client.find client path in - match result with - | Some data -> - let* () = - Lwt_io.printl (Irmin.Type.to_string Client.Contents.t data) - in - Lwt_io.flush Lwt_io.stdout - | None -> - Logs.err (fun l -> - l "Not found: %a" (Irmin.Type.pp Client.Path.t) path); - Lwt.return_unit) + run @@ fun () -> + let (S ((module Client), client)) = client () in + let path = Irmin.Type.of_string Client.Path.t path |> Error.unwrap "path" in + let result = Client.find client path in + Lwt_eio.run_lwt @@ fun () -> + match result with + | Some data -> + let* () = Lwt_io.printl (Irmin.Type.to_string Client.Contents.t data) in + Lwt_io.flush Lwt_io.stdout + | None -> + Logs.err (fun l -> l "Not found: %a" (Irmin.Type.pp Client.Path.t) path); + Lwt.return_unit let mem client path = - run (fun () -> - client >>= fun (S ((module Client), client)) -> - let path = - Irmin.Type.of_string Client.Path.t path |> Error.unwrap "path" - in - let* result = Client.mem client path in - Lwt_io.printl (if result then "true" else "false")) + run @@ fun () -> + let (S ((module Client), client)) = client () in + let path = Irmin.Type.of_string Client.Path.t path |> Error.unwrap "path" in + let result = Client.mem client path in + Lwt_eio.run_lwt @@ fun () -> + Lwt_io.printl (if result then "true" else "false") let mem_tree client path = - run (fun () -> - client >>= fun (S ((module Client), client)) -> - let path = - Irmin.Type.of_string Client.Path.t path |> Error.unwrap "path" - in - let* result = Client.mem_tree client path in - Lwt_io.printl (if result then "true" else "false")) + run @@ fun () -> + let (S ((module Client), client)) = client () in + let path = Irmin.Type.of_string Client.Path.t path |> Error.unwrap "path" in + let result = Client.mem_tree client path in + Lwt_eio.run_lwt @@ fun () -> + Lwt_io.printl (if result then "true" else "false") let set client path author message contents = - run (fun () -> - client >>= fun (S ((module Client), client)) -> - let module Info = Irmin_client_unix.Info (Client.Info) in - let path = - Irmin.Type.of_string Client.Path.t path |> Error.unwrap "path" - in - let contents = - Irmin.Type.of_string Client.Contents.t contents - |> Error.unwrap "contents" - in - let info = Info.v ~author "%s" message in - let+ () = Client.set_exn client path ~info contents in - Logs.app (fun l -> l "OK")) + run @@ fun () -> + let (S ((module Client), client)) = client () in + let module Info = Irmin_client_unix.Info (Client.Info) in + let path = Irmin.Type.of_string Client.Path.t path |> Error.unwrap "path" in + let contents = + Irmin.Type.of_string Client.Contents.t contents |> Error.unwrap "contents" + in + let info = Info.v ~author "%s" message in + Client.set_exn client path ~info contents; + Logs.app (fun l -> l "OK") let remove client path author message = - run (fun () -> - client >>= fun (S ((module Client), client)) -> - let module Info = Irmin_client_unix.Info (Client.Info) in - let path = - Irmin.Type.of_string Client.Path.t path |> Error.unwrap "path" - in - let info = Info.v ~author "%s" message in - let+ () = Client.remove_exn client path ~info in - Logs.app (fun l -> l "OK")) + run @@ fun () -> + let (S ((module Client), client)) = client () in + let module Info = Irmin_client_unix.Info (Client.Info) in + let path = Irmin.Type.of_string Client.Path.t path |> Error.unwrap "path" in + let info = Info.v ~author "%s" message in + Client.remove_exn client path ~info; + Logs.app (fun l -> l "OK") let export client filename = - run (fun () -> - client >>= fun (S ((module Client), client)) -> - let* slice = Client.export (Client.repo client) in - let s = Irmin.Type.(unstage (to_bin_string Client.slice_t) slice) in - Lwt_io.chars_to_file filename (Lwt_stream.of_string s)) + run @@ fun () -> + let (S ((module Client), client)) = client () in + let slice = Client.export (Client.repo client) in + let s = Irmin.Type.(unstage (to_bin_string Client.slice_t) slice) in + Lwt_eio.run_lwt @@ fun () -> + Lwt_io.chars_to_file filename (Lwt_stream.of_string s) let import client filename = - run (fun () -> - client >>= fun (S ((module Client), client)) -> - let* slice = Lwt_io.chars_of_file filename |> Lwt_stream.to_string in - let slice = - Irmin.Type.(unstage (of_bin_string Client.slice_t) slice) - |> Error.unwrap "slice" - in - let+ () = Client.import (Client.repo client) slice in - Logs.app (fun l -> l "OK")) + run @@ fun () -> + let (S ((module Client), client)) = client () in + let slice = + Lwt_eio.run_lwt @@ fun () -> + Lwt_io.chars_of_file filename |> Lwt_stream.to_string + in + let slice = + Irmin.Type.(unstage (of_bin_string Client.slice_t) slice) + |> Error.unwrap "slice" + in + Client.import (Client.repo client) slice; + Logs.app (fun l -> l "OK") let replicate client author message prefix = - Lwt_main.run - ( client >>= fun (S ((module Client), client)) -> - let module Info = Irmin_client_unix.Info (Client.Info) in - let diff input = - Irmin.Type.( - of_json_string - (list - (pair Client.Path.t - (Irmin.Diff.t (pair Client.Contents.t Client.Metadata.t))))) - input - |> Result.get_ok - in - let rec loop () = - let* input = Lwt_io.read_line Lwt_io.stdin in - let batch : Client.Batch.t = - List.fold_left - (fun acc (k, diff) -> - match diff with - | `Updated (_, (value, metadata)) | `Added (value, metadata) -> - Client.Batch.add_value ~metadata k value acc - | `Removed _ -> Client.Batch.remove k acc) - (Client.Batch.v ()) (diff input) - in - let info = Info.v ~author "%s" message in - let prefix = - match prefix with - | Some p -> Irmin.Type.of_string Client.Path.t p |> Result.get_ok - | None -> Client.Path.empty - in - let* _ = Client.Batch.apply ~info client ~path:prefix batch in - loop () - in - loop () ) + run @@ fun () -> + let (S ((module Client), client)) = client () in + let module Info = Irmin_client_unix.Info (Client.Info) in + let diff input = + Irmin.Type.( + of_json_string + (list + (pair Client.Path.t + (Irmin.Diff.t (pair Client.Contents.t Client.Metadata.t))))) + input + |> Result.get_ok + in + let rec loop () = + let input = Lwt_eio.run_lwt @@ fun () -> Lwt_io.read_line Lwt_io.stdin in + let batch : Client.Batch.t = + List.fold_left + (fun acc (k, diff) -> + match diff with + | `Updated (_, (value, metadata)) | `Added (value, metadata) -> + Client.Batch.add_value ~metadata k value acc + | `Removed _ -> Client.Batch.remove k acc) + (Client.Batch.v ()) (diff input) + in + let info = Info.v ~author "%s" message in + let prefix = + match prefix with + | Some p -> Irmin.Type.of_string Client.Path.t p |> Result.get_ok + | None -> Client.Path.empty + in + let (_ : Client.commit_key) = + Client.Batch.apply ~info client ~path:prefix batch + in + loop () + in + loop () + +let replicate client author message prefix = + replicate client author message prefix false 1 let watch client = - Lwt_main.run - ( client >>= fun (S ((module Client), client)) -> - let repo = Client.repo client in - let pp = Irmin.Type.pp (Client.Commit.t repo) in - let* _w = - Client.watch client (fun x -> - match x with - | `Updated (a, b) -> - Logs.app (fun l -> l "Updated (%a, %a)" pp a pp b); - Lwt.return_unit - | `Added a -> - Logs.app (fun l -> l "Added %a" pp a); - Lwt.return_unit - | `Removed a -> - Logs.app (fun l -> l "Removed %a" pp a); - Lwt.return_unit) - in - let x, _ = Lwt.wait () in - x ) + run @@ fun () -> + let (S ((module Client), client)) = client () in + let repo = Client.repo client in + let pp = Irmin.Type.pp (Client.Commit.t repo) in + let _w = + Client.watch client (fun x -> + match x with + | `Updated (a, b) -> Logs.app (fun l -> l "Updated (%a, %a)" pp a pp b) + | `Added a -> Logs.app (fun l -> l "Added %a" pp a) + | `Removed a -> Logs.app (fun l -> l "Removed %a" pp a)) + in + Lwt_eio.run_lwt @@ fun () -> + let x, _ = Lwt.wait () in + x +let watch client = watch client false 0 let pr_str = Format.pp_print_string let path index = diff --git a/src/irmin-server/command.ml b/src/irmin-server/command.ml index 39aeade0e8..eff219ddde 100644 --- a/src/irmin-server/command.ml +++ b/src/irmin-server/command.ml @@ -30,13 +30,13 @@ struct module Commands = struct let resolve_tree (ctx : context) tree = - let* id, tree = + let id, tree = match tree with - | Tree.Key x -> Store.Tree.of_key ctx.repo x >|= fun x -> (None, x) - | Concrete x -> Lwt.return (None, Some (Store.Tree.of_concrete x)) + | Tree.Key x -> (None, Store.Tree.of_key ctx.repo x) + | Concrete x -> (None, Some (Store.Tree.of_concrete x)) in match tree with - | Some t -> Lwt.return (id, t) + | Some t -> (id, t) | None -> Error.raise_error "unknown tree" type store = @@ -47,11 +47,13 @@ struct | `Empty -> Store.empty ctx.repo | `Branch b -> Store.of_branch ctx.repo b | `Commit key -> ( - let* commit = Store.Commit.of_key ctx.repo key in + let commit = Store.Commit.of_key ctx.repo key in match commit with | None -> Error.raise_error "Cannot find commit" | Some commit -> Store.of_commit commit) + let resolve_store ctx t = Lwt_eio.run_eio (fun () -> resolve_store ctx t) + module Ping = struct let name = "ping" @@ -68,7 +70,10 @@ struct let name = "export" let run conn ctx _ depth = - let* slice = Store.Repo.export ?depth ~full:true ~max:`Head ctx.repo in + let* slice = + Lwt_eio.run_eio @@ fun () -> + Store.Repo.export ?depth ~full:true ~max:`Head ctx.repo + in Return.v conn Store.slice_t slice end @@ -79,7 +84,10 @@ struct let name = "import" let run conn ctx _ slice = - let* () = Store.Repo.import ctx.repo slice >|= Error.unwrap "import" in + let* () = + (Lwt_eio.run_eio @@ fun () -> Store.Repo.import ctx.repo slice) + >|= Error.unwrap "import" + in Return.ok conn end @@ -106,6 +114,7 @@ struct let run conn ctx _ key = let* x = + Lwt_eio.run_eio @@ fun () -> Repo.batch ctx.repo (fun contents _ _ -> Contents.mem contents key) in Return.v conn res_t x @@ -119,6 +128,7 @@ struct let run conn ctx _ key = let* v = + Lwt_eio.run_eio @@ fun () -> Repo.batch ctx.repo (fun contents _ _ -> Contents.find contents key) in Return.v conn res_t v @@ -132,6 +142,7 @@ struct let run conn ctx _ value = let* k = + Lwt_eio.run_eio @@ fun () -> Repo.batch ctx.repo (fun contents _ _ -> Contents.add contents value) in @@ -146,6 +157,7 @@ struct let run conn ctx _ (hash, value) = let* k = + Lwt_eio.run_eio @@ fun () -> Repo.batch ctx.repo (fun contents _ _ -> Contents.unsafe_add contents hash value) in @@ -160,6 +172,7 @@ struct let run conn ctx _ hash = let* v = + Lwt_eio.run_eio @@ fun () -> Repo.batch ctx.repo (fun contents _ _ -> Contents.index contents hash) in @@ -177,10 +190,11 @@ struct let run conn ctx _ (old, a, b) = let* res = + Lwt_eio.run_eio @@ fun () -> Repo.batch ctx.repo (fun contents _ _ -> let merge = Contents.merge contents in let f = Irmin.Merge.f merge in - let old () = Lwt.return_ok old in + let old () = Ok old in f ~old a b) in Return.v conn res_t res @@ -205,7 +219,10 @@ struct type res = bool [@@deriving irmin] let run conn ctx _ key = - let* x = Repo.batch ctx.repo (fun _ node _ -> Node.mem node key) in + let* x = + Lwt_eio.run_eio @@ fun () -> + Repo.batch ctx.repo (fun _ node _ -> Node.mem node key) + in Return.v conn res_t x end @@ -216,7 +233,10 @@ struct type res = value option [@@deriving irmin] let run conn ctx _ key = - let* v = Repo.batch ctx.repo (fun _ node _ -> Node.find node key) in + let* v = + Lwt_eio.run_eio @@ fun () -> + Repo.batch ctx.repo (fun _ node _ -> Node.find node key) + in Return.v conn res_t v end @@ -227,7 +247,10 @@ struct type res = key [@@deriving irmin] let run conn ctx _ value = - let* k = Repo.batch ctx.repo (fun _ node _ -> Node.add node value) in + let* k = + Lwt_eio.run_eio @@ fun () -> + Repo.batch ctx.repo (fun _ node _ -> Node.add node value) + in Return.v conn res_t k end @@ -239,6 +262,7 @@ struct let run conn ctx _ (hash, value) = let* k = + Lwt_eio.run_eio @@ fun () -> Repo.batch ctx.repo (fun _ node _ -> Node.unsafe_add node hash value) in @@ -252,7 +276,10 @@ struct type res = key option [@@deriving irmin] let run conn ctx _ hash = - let* v = Repo.batch ctx.repo (fun _ node _ -> Node.index node hash) in + let* v = + Lwt_eio.run_eio @@ fun () -> + Repo.batch ctx.repo (fun _ node _ -> Node.index node hash) + in Return.v conn res_t v end @@ -267,10 +294,11 @@ struct let run conn ctx _ (old, a, b) = let* res = + Lwt_eio.run_eio @@ fun () -> Repo.batch ctx.repo (fun _ node _ -> let merge = Node.merge node in let f = Irmin.Merge.f merge in - let old () = Lwt.return_ok old in + let old () = Ok old in f ~old a b) in Return.v conn res_t res @@ -296,7 +324,7 @@ struct let run conn ctx _ key = let x = Repo.commit_t ctx.repo in - let* v = Commit.mem x key in + let* v = Lwt_eio.run_eio @@ fun () -> Commit.mem x key in Return.v conn res_t v end @@ -308,7 +336,7 @@ struct let run conn ctx _ key = let x = Repo.commit_t ctx.repo in - let* v = Commit.find x key in + let* v = Lwt_eio.run_eio @@ fun () -> Commit.find x key in Return.v conn res_t v end @@ -320,6 +348,7 @@ struct let run conn ctx _ value = let* k = + Lwt_eio.run_eio @@ fun () -> Repo.batch ctx.repo (fun _ _ commit -> Commit.add commit value) in Return.v conn res_t k @@ -333,6 +362,7 @@ struct let run conn ctx _ (hash, value) = let* k = + Lwt_eio.run_eio @@ fun () -> Repo.batch ctx.repo (fun _ _ commit -> Commit.unsafe_add commit hash value) in @@ -347,6 +377,7 @@ struct let run conn ctx _ hash = let* v = + Lwt_eio.run_eio @@ fun () -> Repo.batch ctx.repo (fun _ _ commit -> Commit.index commit hash) in Return.v conn res_t v @@ -364,10 +395,11 @@ struct let run conn ctx _ (info, (old, a, b)) = let info () = info in let* res = + Lwt_eio.run_eio @@ fun () -> Repo.batch ctx.repo (fun _ _ commit -> let merge = Commit.merge commit ~info in let f = Irmin.Merge.f merge in - let old () = Lwt.return_ok old in + let old () = Ok old in f ~old a b) in Return.v conn res_t res @@ -386,7 +418,7 @@ struct let run conn ctx _ branch = let b = Repo.branch_t ctx.repo in - let* x = Branch.mem b branch in + let* x = Lwt_eio.run_eio @@ fun () -> Branch.mem b branch in Return.v conn res_t x end @@ -398,7 +430,7 @@ struct let run conn ctx _ branch = let b = Repo.branch_t ctx.repo in - let* commit = Branch.find b branch in + let* commit = Lwt_eio.run_eio @@ fun () -> Branch.find b branch in Return.v conn res_t commit end @@ -410,7 +442,7 @@ struct let run conn ctx _ (branch, commit) = let b = Repo.branch_t ctx.repo in - let* () = Branch.set b branch commit in + let* () = Lwt_eio.run_eio @@ fun () -> Branch.set b branch commit in Return.v conn res_t () end @@ -422,7 +454,9 @@ struct let run conn ctx _ (branch, test, set) = let b = Repo.branch_t ctx.repo in - let* res = Branch.test_and_set b branch ~test ~set in + let* res = + Lwt_eio.run_eio @@ fun () -> Branch.test_and_set b branch ~test ~set + in Return.v conn res_t res end @@ -434,7 +468,7 @@ struct let run conn ctx _ branch = let b = Repo.branch_t ctx.repo in - let* () = Branch.remove b branch in + let* () = Lwt_eio.run_eio @@ fun () -> Branch.remove b branch in Return.v conn res_t () end @@ -446,7 +480,7 @@ struct let run conn ctx _ () = let b = Repo.branch_t ctx.repo in - let* b = Branch.list b in + let* b = Lwt_eio.run_eio @@ fun () -> Branch.list b in Return.v conn res_t b end @@ -458,7 +492,7 @@ struct let run conn ctx _ () = let b = Repo.branch_t ctx.repo in - let* () = Branch.clear b in + let* () = Lwt_eio.run_eio @@ fun () -> Branch.clear b in Return.v conn res_t () end @@ -474,11 +508,14 @@ struct match ctx.branch_watch with | Some watch -> ctx.branch_watch <- None; - Branch.unwatch b watch + + Lwt_eio.run_eio @@ fun () -> Branch.unwatch b watch | None -> Lwt.return_unit in let* watch = + Lwt_eio.run_eio @@ fun () -> Branch.watch b ?init (fun key diff -> + Lwt_eio.run_lwt @@ fun () -> let diff_t = Irmin.Diff.t Store.commit_key_t in Lwt.catch (fun () -> @@ -507,11 +544,13 @@ struct match ctx.branch_watch with | Some watch -> ctx.branch_watch <- None; - Branch.unwatch b watch + Lwt_eio.run_eio @@ fun () -> Branch.unwatch b watch | None -> Lwt.return_unit in let* watch = + Lwt_eio.run_eio @@ fun () -> Branch.watch_key b key ?init (fun diff -> + Lwt_eio.run_lwt @@ fun () -> let diff_t = Irmin.Diff.t Store.commit_key_t in Lwt.catch (fun () -> @@ -536,7 +575,7 @@ struct match ctx.branch_watch with | Some watch -> ctx.branch_watch <- None; - Branch.unwatch b watch + Lwt_eio.run_eio @@ fun () -> Branch.unwatch b watch | None -> Lwt.return_unit in Return.v conn res_t () @@ -562,29 +601,27 @@ struct let run conn ctx _ ((store, path), info, l) = let* store = resolve_store ctx store in - let* () = - Store.with_tree_exn store path - ~info:(fun () -> info) - (fun tree -> - let tree = Option.value ~default:(Store.Tree.empty ()) tree in - let* tree = - Lwt_list.fold_left_s - (fun tree (path, value) -> - match value with - | `Contents (`Hash value, metadata) -> - let* value = Store.Contents.of_hash ctx.repo value in - Store.Tree.add tree path ?metadata (Option.get value) - | `Contents (`Value value, metadata) -> - Store.Tree.add tree path ?metadata value - | `Tree t -> - let* _, tree' = resolve_tree ctx t in - Store.Tree.add_tree tree path tree' - | `Remove -> Store.Tree.remove tree path) - tree l - in - Lwt.return (Some tree)) - in - let* c = Store.Head.get store in + Store.with_tree_exn store path + ~info:(fun () -> info) + (fun tree -> + let tree = Option.value ~default:(Store.Tree.empty ()) tree in + let tree = + List.fold_left + (fun tree (path, value) -> + match value with + | `Contents (`Hash value, metadata) -> + let value = Store.Contents.of_hash ctx.repo value in + Store.Tree.add tree path ?metadata (Option.get value) + | `Contents (`Value value, metadata) -> + Store.Tree.add tree path ?metadata value + | `Tree t -> + let _, tree' = resolve_tree ctx t in + Store.Tree.add_tree tree path tree' + | `Remove -> Store.Tree.remove tree path) + tree l + in + Some tree); + let c = Store.Head.get store in Return.v conn res_t (Store.Commit.key c) end end @@ -600,7 +637,7 @@ struct let run conn ctx _ (store, path) = let* store = resolve_store ctx store in - let* res = Store.mem store path in + let* res = Lwt_eio.run_eio @@ fun () -> Store.mem store path in Return.v conn res_t res end @@ -612,7 +649,7 @@ struct let run conn ctx _ (store, path) = let* store = resolve_store ctx store in - let* res = Store.mem_tree store path in + let* res = Lwt_eio.run_eio @@ fun () -> Store.mem_tree store path in Return.v conn res_t res end @@ -624,7 +661,7 @@ struct let run conn ctx _ (store, path) = let* store = resolve_store ctx store in - let* x = Store.find store path in + let* x = Lwt_eio.run_eio @@ fun () -> Store.find store path in Return.v conn res_t x end @@ -636,11 +673,11 @@ struct let run conn ctx _ (store, path) = let* store = resolve_store ctx store in - let* x = Store.find_tree store path in + let* x = Lwt_eio.run_eio @@ fun () -> Store.find_tree store path in match x with | None -> Return.v conn res_t None | Some x -> - let* x = Store.Tree.to_concrete x in + let* x = Lwt_eio.run_eio @@ fun () -> Store.Tree.to_concrete x in Return.v conn res_t (Some x) end @@ -653,7 +690,8 @@ struct | None -> Lwt.return None | Some parents -> let* parents = - Lwt_list.filter_map_s + Lwt_eio.run_eio @@ fun () -> + List.filter_map (fun hash -> Store.Commit.of_hash ctx.repo hash) parents in @@ -672,6 +710,7 @@ struct let* parents = mk_parents ctx parents in let* store = resolve_store ctx store in let* () = + Lwt_eio.run_eio @@ fun () -> Store.remove_exn ?clear ?retries ?allow_empty ?parents store path ~info:(fun () -> info) in diff --git a/src/irmin-server/dune b/src/irmin-server/dune index 8bc80dde7a..aaf938a668 100644 --- a/src/irmin-server/dune +++ b/src/irmin-server/dune @@ -1,6 +1,6 @@ (library (name irmin_server) (public_name irmin-server) - (libraries logs fmt irmin lwt cmdliner) + (libraries logs fmt irmin lwt lwt_eio eio_main cmdliner) (preprocess (pps ppx_irmin.internal))) diff --git a/src/irmin-server/unix/server.ml b/src/irmin-server/unix/server.ml index 8273d47ab4..44d9881863 100644 --- a/src/irmin-server/unix/server.ml +++ b/src/irmin-server/unix/server.ml @@ -70,7 +70,7 @@ module Make (Codec : Conn.Codec.S) (Store : Irmin.Generic_key.S) = struct `Port port ) )) | x -> invalid_arg ("Unknown server scheme: " ^ x) in - let+ repo = Store.Repo.v config in + let+ repo = Lwt_eio.run_eio @@ fun () -> Store.Repo.v config in let start_time = Unix.time () in let info = Command.Server_info.{ start_time } in { ctx; uri; server; dashboard; config; repo; info } @@ -83,16 +83,16 @@ module Make (Codec : Conn.Codec.S) (Store : Irmin.Generic_key.S) = struct let[@tailrec] rec loop repo conn client info : unit Lwt.t = if Conn.is_closed conn then let* () = - match client.Command.watch with - | Some w -> Store.unwatch w - | None -> Lwt.return_unit + Lwt_eio.run_eio @@ fun () -> + match client.Command.watch with Some w -> Store.unwatch w | None -> () in let* () = + Lwt_eio.run_eio @@ fun () -> match client.Command.branch_watch with | Some w -> let b = Store.Backend.Repo.branch_t client.repo in Store.Backend.Branch.unwatch b w - | None -> Lwt.return_unit + | None -> () in Lwt.return_unit else @@ -233,39 +233,35 @@ module Make (Codec : Conn.Codec.S) (Store : Irmin.Generic_key.S) = struct let dashboard t mode = let list store prefix = - let* keys = Store.list store prefix in - let+ keys = - Lwt_list.map_s - (fun (path, tree) -> - let path = Store.Path.rcons prefix path in - let* kind = Store.Tree.kind tree Store.Path.empty in - match kind with - | Some `Contents -> - Lwt.return_some (path, "contents", Store.Tree.hash tree) - | Some `Node -> Lwt.return_some (path, "node", Store.Tree.hash tree) - | None -> Lwt.return_none) - keys - in - List.filter_map Fun.id keys + let keys = Store.list store prefix in + List.filter_map + (fun (path, tree) -> + let path = Store.Path.rcons prefix path in + let kind = Store.Tree.kind tree Store.Path.empty in + match kind with + | Some `Contents -> Some (path, "contents", Store.Tree.hash tree) + | Some `Node -> Some (path, "node", Store.Tree.hash tree) + | None -> None) + keys in let data_callback prefix branch = let* store = + Lwt_eio.run_eio @@ fun () -> match branch with | `Hash commit -> ( - let* commit = Store.Commit.of_hash t.repo commit in + let commit = Store.Commit.of_hash t.repo commit in match commit with | Some commit -> Store.of_commit commit | None -> failwith "Invalid commit") | `Branch branch -> Store.of_branch t.repo branch in let* is_contents = - Store.kind store prefix >|= function - | Some `Contents -> true - | _ -> false + Lwt_eio.run_eio @@ fun () -> + match Store.kind store prefix with Some `Contents -> true | _ -> false in let res = Cohttp_lwt_unix.Response.make ~status:`OK () in if is_contents then - let* contents = Store.get store prefix in + let* contents = Lwt_eio.run_eio @@ fun () -> Store.get store prefix in let contents' = Irmin.Type.to_json_string Store.contents_t contents in let body = Printf.sprintf {|{"contents": %s, "hash": %s }|} contents' @@ -275,19 +271,17 @@ module Make (Codec : Conn.Codec.S) (Store : Irmin.Generic_key.S) = struct let body = Cohttp_lwt.Body.of_string body in Lwt.return (res, body) else - let* keys = list store prefix in - let* keys = - Lwt_list.map_s + let* keys = Lwt_eio.run_eio @@ fun () -> list store prefix in + let keys = + List.map (fun (path, kind, hash) -> Format.sprintf {|{"path": "%s", "kind": "%s", "hash": "%s"}|} (Irmin.Type.to_string Store.path_t path) kind - (Irmin.Type.to_string Store.hash_t hash) - |> Lwt.return) + (Irmin.Type.to_string Store.hash_t hash)) keys in let keys = String.concat "," keys in - let body = Cohttp_lwt.Body.of_string (Printf.sprintf "[%s]" keys) in Lwt.return (res, body) in diff --git a/test/irmin-client/test.ml b/test/irmin-client/test.ml index 07be16e0cb..e51a869c95 100644 --- a/test/irmin-client/test.ml +++ b/test/irmin-client/test.ml @@ -14,7 +14,6 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Lwt.Syntax open Irmin_client_unix open Util module Info = Info (Client.Info) @@ -36,38 +35,18 @@ end module Make (R : R) = struct let () = at_exit (fun () -> try Unix.kill R.pid Sys.sigint with _ -> ()) let config = Irmin_client_unix.config R.uri - let client = Lwt_main.run (Client.Repo.v config) - let clean ~config:_ = Client.Branch.remove client "main" module X = Irmin_mem.KV.Make (Irmin.Contents.String) module Store = Irmin_client_unix.Make (X) - let suite = + let suite () = + let client = Client.Repo.v config in + let clean ~config:_ = Client.Branch.remove client "main" in Irmin_test.Suite.create_generic_key ~name:R.kind ~store:(module Store) ~config ~clean () end -let kind, pid, uri = run_server `Unix_domain - -module Unix_socket = Make (struct - let pid = pid - let uri = uri - let kind = kind -end) - -module Tcp_socket = Make (struct - let kind, pid, uri = run_server `Tcp -end) - -module Websocket = Make (struct - let kind, pid, uri = run_server `Websocket -end) - -let config = Irmin_client_unix.config uri -let client = Lwt_main.run (Client.Repo.v config) -let client () = Client.dup client - let error = Alcotest.testable (Fmt.using Error.to_string Fmt.string) (fun a b -> Error.to_string a = Error.to_string b) @@ -77,32 +56,51 @@ let ty t = (Fmt.using (Irmin.Type.to_string t) Fmt.string) (fun a b -> Irmin.Type.(unstage (equal t)) a b) -let ping () = +let ping client () = let open Client in - let* client = client () in + let client = client () in Logs.debug (fun l -> l "BEFORE PING"); - let+ r = ping client in + let r = ping client in Logs.debug (fun l -> l "AFTER PING"); Alcotest.(check (result unit error)) "ping" (Ok ()) r -let misc = [ ("ping", `Quick, ping) ] -let misc = [ ("misc", misc) ] - -let () = +let misc client = [ ("ping", `Quick, ping client) ] +let misc client = [ ("misc", misc client) ] + +let main () = + let kind, pid, uri = run_server `Unix_domain in + let config = Irmin_client_unix.config uri in + let client = Client.Repo.v config in + let client () = Lwt_eio.run_lwt @@ fun () -> Client.dup client in + let module Unix_socket = Make (struct + let pid = pid + let uri = uri + let kind = kind + end) in + let module Tcp_socket = Make (struct + let kind, pid, uri = run_server `Tcp + end) in + let module Websocket = Make (struct + let kind, pid, uri = run_server `Websocket + end) in let slow = Sys.getenv_opt "SLOW" |> Option.is_some in let only = Sys.getenv_opt "ONLY" in let tests = match only with - | Some "ws" -> [ (`Quick, Websocket.suite) ] - | Some "tcp" -> [ (`Quick, Tcp_socket.suite) ] - | Some "unix" -> [ (`Quick, Unix_socket.suite) ] + | Some "ws" -> [ (`Quick, Websocket.suite ()) ] + | Some "tcp" -> [ (`Quick, Tcp_socket.suite ()) ] + | Some "unix" -> [ (`Quick, Unix_socket.suite ()) ] | Some s -> failwith ("Invalid selection: " ^ s) | None -> [ - (`Quick, Unix_socket.suite); - (`Quick, Tcp_socket.suite); - (`Quick, Websocket.suite); + (`Quick, Unix_socket.suite ()); + (`Quick, Tcp_socket.suite ()); + (`Quick, Websocket.suite ()); ] in - Lwt_main.run - (Irmin_test.Store.run "irmin-server" ~sleep:Lwt_unix.sleep ~slow ~misc tests) + Irmin_test.Store.run "irmin-server" ~sleep:Eio_unix.sleep ~slow + ~misc:(misc client) tests + +let () = + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> main () diff --git a/test/irmin-client/util.ml b/test/irmin-client/util.ml index 14296af0e3..4b89c768aa 100644 --- a/test/irmin-client/util.ml +++ b/test/irmin-client/util.ml @@ -37,7 +37,7 @@ let run_server s = | 0 -> let () = Irmin.Backend.Watch.set_listen_dir_hook Irmin_watcher.hook in let conf = Irmin_mem.config () in - Lwt_main.run (Server.v ~uri conf >>= Server.serve); + Lwt_eio.run_lwt (fun () -> Server.v ~uri conf >>= Server.serve); (kind, 0, uri) | n -> Unix.sleep 3; From 4f2d16a43bcc4711ef1df5bc20bea57eac0f7b04 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Mon, 21 Aug 2023 18:00:22 +0200 Subject: [PATCH 72/99] irmin-pack: remove Io.Unix constraint --- irmin-pack-tools.opam | 2 +- irmin-pack.opam | 2 +- src/irmin-pack/unix/async.ml | 12 ++++++++++++ src/irmin-pack/unix/checks.ml | 4 +++- src/irmin-pack/unix/dispatcher.ml | 4 +--- src/irmin-pack/unix/dispatcher_intf.ml | 3 +-- src/irmin-pack/unix/file_manager.ml | 4 ++++ src/irmin-pack/unix/gc_args.ml | 2 +- src/irmin-pack/unix/gc_worker.ml | 12 +++++++++--- src/irmin-pack/unix/irmin_pack_unix.ml | 10 +++++++++- src/irmin-pack/unix/irmin_pack_unix.mli | 10 ++++++++++ src/irmin-pack/unix/pack_index.ml | 17 ++++++++++------- src/irmin-pack/unix/pack_index_intf.ml | 3 +++ src/irmin-pack/unix/sparse_file.ml | 2 +- src/irmin-pack/unix/store.ml | 12 ++++++------ src/irmin-pack/unix/store.mli | 5 ++++- src/irmin-pack/unix/store_intf.ml | 2 +- 17 files changed, 77 insertions(+), 29 deletions(-) diff --git a/irmin-pack-tools.opam b/irmin-pack-tools.opam index 18160121ed..4c0c4da7fd 100644 --- a/irmin-pack-tools.opam +++ b/irmin-pack-tools.opam @@ -38,7 +38,7 @@ pin-depends: [ [ "terminal.dev" "git+https://github.com/craigfe/progress#76e7c791bd17c28b3e605d9c383102a30345e029" ] [ "progress.dev" "git+https://github.com/craigfe/progress#76e7c791bd17c28b3e605d9c383102a30345e029" ] # Needed by Irmin-pack - [ "index.dev" "git+https://github.com/patricoferris/index#cfa32e984b633d08b2f0c1fc1f792925c6d74f8e" ] + # [ "index.dev" "git+https://github.com/patricoferris/index#cfa32e984b633d08b2f0c1fc1f792925c6d74f8e" ] ] synopsis: "Utils for Irmin-pack" diff --git a/irmin-pack.opam b/irmin-pack.opam index c75df5320f..a1428f2f29 100644 --- a/irmin-pack.opam +++ b/irmin-pack.opam @@ -36,7 +36,7 @@ pin-depends: [ [ "terminal.dev" "git+https://github.com/craigfe/progress#76e7c791bd17c28b3e605d9c383102a30345e029" ] [ "progress.dev" "git+https://github.com/craigfe/progress#76e7c791bd17c28b3e605d9c383102a30345e029" ] # Needed by Irmin-pack - [ "index.dev" "git+https://github.com/patricoferris/index#cfa32e984b633d08b2f0c1fc1f792925c6d74f8e" ] + # [ "index.dev" "git+https://github.com/patricoferris/index#cfa32e984b633d08b2f0c1fc1f792925c6d74f8e" ] ] synopsis: "Irmin backend which stores values in a pack file" diff --git a/src/irmin-pack/unix/async.ml b/src/irmin-pack/unix/async.ml index 4c83400ecc..a9a09a4b69 100644 --- a/src/irmin-pack/unix/async.ml +++ b/src/irmin-pack/unix/async.ml @@ -58,6 +58,17 @@ module Unix = struct end let async f = + let exit_code = + match f () with + | () -> Exit_code.success + | exception e -> + [%log.err + "Unhandled exception in child process %s" (Printexc.to_string e)]; + Exit_code.unhandled_exn + in + { pid = -1; status = `Success; lock = Eio.Mutex.create () } + + (* Stdlib.flush_all (); match Unix.fork () with | 0 -> @@ -76,6 +87,7 @@ module Unix = struct | pid -> Exit.add pid; { pid; status = `Running; lock = Eio.Mutex.create () } + *) let status_of_process_outcome = function | Unix.WEXITED n when n = Exit_code.success -> `Success diff --git a/src/irmin-pack/unix/checks.ml b/src/irmin-pack/unix/checks.ml index 08ca88d0b2..52365bbe46 100644 --- a/src/irmin-pack/unix/checks.ml +++ b/src/irmin-pack/unix/checks.ml @@ -63,7 +63,9 @@ let ppf_or_null ppf = module Make (Store : Store) = struct module Hash = Store.Hash - module Index = Pack_index.Make (Hash) + + module Index = + Pack_index.Make_io (Io.Unix) (Index_unix.Private.Platform) (Hash) (** Read basic metrics from an existing store. *) module Stat = struct diff --git a/src/irmin-pack/unix/dispatcher.ml b/src/irmin-pack/unix/dispatcher.ml index 45057334e2..1e430579cf 100644 --- a/src/irmin-pack/unix/dispatcher.ml +++ b/src/irmin-pack/unix/dispatcher.ml @@ -18,9 +18,7 @@ open Import include Dispatcher_intf module Payload = Control_file.Payload.Upper.Latest -(* The following [with module Io = Io.Unix] forces unix *) -module Make (Fm : File_manager.S with module Io = Io.Unix) : - S with module Fm = Fm = struct +module Make (Fm : File_manager.S) : S with module Fm = Fm = struct module Fm = Fm module Io = Fm.Io module Suffix = Fm.Suffix diff --git a/src/irmin-pack/unix/dispatcher_intf.ml b/src/irmin-pack/unix/dispatcher_intf.ml index 6b1ed88622..d4c9dc7469 100644 --- a/src/irmin-pack/unix/dispatcher_intf.ml +++ b/src/irmin-pack/unix/dispatcher_intf.ml @@ -100,6 +100,5 @@ end module type Sigs = sig module type S = S - module Make (Fm : File_manager.S with module Io = Io.Unix) : - S with module Fm = Fm + module Make (Fm : File_manager.S) : S with module Fm = Fm end diff --git a/src/irmin-pack/unix/file_manager.ml b/src/irmin-pack/unix/file_manager.ml index 9b79af63bc..d73044ab5e 100644 --- a/src/irmin-pack/unix/file_manager.ml +++ b/src/irmin-pack/unix/file_manager.ml @@ -258,6 +258,9 @@ struct | None -> Ok () let cleanup ~root ~generation ~chunk_start_idx ~chunk_num ~lower = + ignore (root, generation, chunk_start_idx, chunk_num, lower); + Ok () + (* let () = Sys.readdir root |> Array.to_list @@ -278,6 +281,7 @@ struct "Could not remove residual file %s: %s" filename error]) in Option.might (Lower.cleanup ~generation) lower + *) let add_volume_and_update_control lower control = let open Result_syntax in diff --git a/src/irmin-pack/unix/gc_args.ml b/src/irmin-pack/unix/gc_args.ml index 3441c51319..0880aa85a5 100644 --- a/src/irmin-pack/unix/gc_args.ml +++ b/src/irmin-pack/unix/gc_args.ml @@ -17,7 +17,7 @@ open! Import module type S = sig - module Fm : File_manager.S with module Io = Io.Unix + module Fm : File_manager.S module Async : Async.S module Errs : Io_errors.S with module Io = Fm.Io module Dispatcher : Dispatcher.S with module Fm = Fm diff --git a/src/irmin-pack/unix/gc_worker.ml b/src/irmin-pack/unix/gc_worker.ml index dc311edd37..bfc01b2cd7 100644 --- a/src/irmin-pack/unix/gc_worker.ml +++ b/src/irmin-pack/unix/gc_worker.ml @@ -426,12 +426,18 @@ module Make (Args : Gc_args.S) = struct let run_and_output_result ~lower_root ~generation ~new_files_path root commit_key new_suffix_start_offset = let result = - Errs.catch (fun () -> - run ~lower_root ~generation ~new_files_path root commit_key - new_suffix_start_offset) + try + Errs.catch (fun () -> + run ~lower_root ~generation ~new_files_path root commit_key + new_suffix_start_offset) + with e -> + Format.printf "GC ERROR: %s@." (Printexc.to_string e); + Printexc.print_backtrace stdout; + raise e in Errs.log_if_error "gc run" result; let write_result = write_gc_output ~root ~generation result in + Format.printf "GC WORKER is done!@."; write_result |> Errs.log_if_error "writing gc output" (* No need to raise or log if [result] is [Error _], we've written it in the file. *) diff --git a/src/irmin-pack/unix/irmin_pack_unix.ml b/src/irmin-pack/unix/irmin_pack_unix.ml index 9aa8edeef0..8b4309fd2b 100644 --- a/src/irmin-pack/unix/irmin_pack_unix.ml +++ b/src/irmin-pack/unix/irmin_pack_unix.ml @@ -17,8 +17,12 @@ (** {1 Store} *) module type S = Store_intf.S +module type Io_s = Io.S -module Maker = Store.Maker +module Maker_io = Store.Maker + +module Maker (Config : Irmin_pack.Conf.S) = + Store.Maker (Io.Unix) (Index_unix.Private.Platform) (Config) module KV (Config : Irmin_pack.Conf.S) = struct type endpoint = unit @@ -52,6 +56,7 @@ module Async = Async module Errors = Errors module Io_errors = Io_errors module Control_file = Control_file +module Control_file_intf = Control_file_intf module Append_only_file = Append_only_file module Chunked_suffix = Chunked_suffix module Ranges = Ranges @@ -60,3 +65,6 @@ module File_manager = File_manager module Lower = Lower module Utils = Utils module Lru = Lru +module Gc_raw = Gc +module Traverse_pack_file = Traverse_pack_file +module Snapshot = Snapshot diff --git a/src/irmin-pack/unix/irmin_pack_unix.mli b/src/irmin-pack/unix/irmin_pack_unix.mli index 206ff27ac9..589918d3ad 100644 --- a/src/irmin-pack/unix/irmin_pack_unix.mli +++ b/src/irmin-pack/unix/irmin_pack_unix.mli @@ -23,6 +23,12 @@ (** {1 Store} *) module type S = Store.S +module type Io_s = Io.S + +module Maker_io + (Io : Io.S) + (Io_index : Index.Platform.S) + (Config : Irmin_pack.Conf.S) : Store.Maker module Maker (Config : Irmin_pack.Conf.S) : Store.Maker module KV (Config : Irmin_pack.Conf.S) : Store.KV @@ -57,6 +63,7 @@ module Async = Async module Errors = Errors module Io_errors = Io_errors module Control_file = Control_file +module Control_file_intf = Control_file_intf module Append_only_file = Append_only_file module Chunked_suffix = Chunked_suffix module Ranges = Ranges @@ -65,3 +72,6 @@ module File_manager = File_manager module Lower = Lower module Utils = Utils module Lru = Lru +module Gc_raw = Gc +module Traverse_pack_file = Traverse_pack_file +module Snapshot = Snapshot diff --git a/src/irmin-pack/unix/pack_index.ml b/src/irmin-pack/unix/pack_index.ml index f7d0b3f7c6..c8bdb225a6 100644 --- a/src/irmin-pack/unix/pack_index.ml +++ b/src/irmin-pack/unix/pack_index.ml @@ -18,7 +18,8 @@ open! Import include Pack_index_intf -module Make (K : Irmin.Hash.S) = struct +module Make_io (Io : Io.S) (Io_index : Index.Platform.S) (K : Irmin.Hash.S) = +struct module Key = struct type t = K.t [@@deriving irmin ~short_hash ~equal ~to_bin_string ~decode_bin] @@ -60,9 +61,9 @@ module Make (K : Irmin.Hash.S) = struct module Stats = Index.Stats module I = Index - module Index = Index_unix.Make (Key) (Val) (Index.Cache.Unbounded) + module Index = Index.Make (Key) (Val) (Io_index) (Index.Cache.Unbounded) include Index - module Io = Io.Unix + module Io = Io let v_exn = let cache = None in @@ -83,7 +84,7 @@ module Make (K : Irmin.Hash.S) = struct error is expected to be raised when a RO instance attemps an opening on a non-existing file. *) assert false - | Unix.Unix_error (x, y, z) -> Error (`Io_misc (x, y, z)) + (* | Unix.Unix_error (x, y, z) -> Error (`Io_misc (x, y, z)) *) | Failure msg -> Error (`Index_failure msg) let add ?overcommit t k v = replace ?overcommit t k v @@ -97,7 +98,7 @@ module Make (K : Irmin.Hash.S) = struct with | I.RO_not_allowed -> Error `Ro_not_allowed | Index_unix.Private.Raw.Not_written -> assert false - | Unix.Unix_error (x, y, z) -> Error (`Io_misc (x, y, z)) + (* | Unix.Unix_error (x, y, z) -> Error (`Io_misc (x, y, z)) *) | Failure msg -> Error (`Index_failure msg) let reload t = @@ -107,7 +108,7 @@ module Make (K : Irmin.Hash.S) = struct with | I.RO_not_allowed -> Error `Ro_not_allowed | Index_unix.Private.Raw.Not_written -> assert false - | Unix.Unix_error (x, y, z) -> Error (`Io_misc (x, y, z)) + (* | Unix.Unix_error (x, y, z) -> Error (`Io_misc (x, y, z)) *) | Failure msg -> Error (`Index_failure msg) let flush t ~with_fsync = @@ -117,6 +118,8 @@ module Make (K : Irmin.Hash.S) = struct with | I.RO_not_allowed -> Error `Ro_not_allowed | Index_unix.Private.Raw.Not_written -> assert false - | Unix.Unix_error (x, y, z) -> Error (`Io_misc (x, y, z)) + (* | Unix.Unix_error (x, y, z) -> Error (`Io_misc (x, y, z)) *) | Failure msg -> Error (`Index_failure msg) end + +module Make = Make_io (Io.Unix) (Index_unix.Private.Platform) diff --git a/src/irmin-pack/unix/pack_index_intf.ml b/src/irmin-pack/unix/pack_index_intf.ml index c1d74e0274..4f15380de8 100644 --- a/src/irmin-pack/unix/pack_index_intf.ml +++ b/src/irmin-pack/unix/pack_index_intf.ml @@ -71,5 +71,8 @@ end module type Sigs = sig module type S = S + module Make_io (Io : Io.S) (Io_index : Index.Platform.S) (K : Irmin.Hash.S) : + S with type key = K.t and module Io = Io + module Make (K : Irmin.Hash.S) : S with type key = K.t and module Io = Io.Unix end diff --git a/src/irmin-pack/unix/sparse_file.ml b/src/irmin-pack/unix/sparse_file.ml index 43c30867bf..44657ead61 100644 --- a/src/irmin-pack/unix/sparse_file.ml +++ b/src/irmin-pack/unix/sparse_file.ml @@ -40,7 +40,7 @@ end = struct let open_ro ~fn ~sz = let open Result_syntax in - assert (Sys.file_exists fn); + assert (Io.classify_path fn = `File); let+ fd = Io.open_ ~path:fn ~readonly:true in let size = sz / 8 in let arr = BigArr1.create Bigarray.Int64 Bigarray.c_layout size in diff --git a/src/irmin-pack/unix/store.ml b/src/irmin-pack/unix/store.ml index 4713db1db4..14cd1eccd9 100644 --- a/src/irmin-pack/unix/store.ml +++ b/src/irmin-pack/unix/store.ml @@ -17,7 +17,8 @@ open! Import include Store_intf -module Maker (Config : Conf.S) = struct +module Maker (Io : Io.S) (Io_index : Index.Platform.S) (Config : Conf.S) = +struct type endpoint = unit include Pack_key.Store_spec @@ -31,8 +32,7 @@ module Maker (Config : Conf.S) = struct end module H = Schema.Hash - module Io = Io.Unix - module Index = Pack_index.Make (H) + module Index = Pack_index.Make_io (Io) (Io_index) (H) module Errs = Io_errors.Make (Io) module File_manager = File_manager.Make (Io) (Index) (Errs) module Dict = File_manager.Dict @@ -614,9 +614,9 @@ module Maker (Config : Conf.S) = struct Fmt.str "Pack_error: %a" Errors.pp_base_error error | Irmin.Closed -> "Irmin.Closed" | Irmin_pack.RO_not_allowed -> "Irmin_pack.RO_not_allowed" - | Unix.Unix_error (err, s1, s2) -> - let pp = Irmin.Type.pp Io.misc_error_t in - Fmt.str "Unix_error: %a" pp (err, s1, s2) + (* | Unix.Unix_error (err, s1, s2) -> *) + (* let pp = Irmin.Type.pp Io.misc_error_t in *) + (* Fmt.str "Unix_error: %a" pp (err, s1, s2) *) | exn -> raise exn in let error_msg = Fmt.str "[%s] resulted in error: %s" context err in diff --git a/src/irmin-pack/unix/store.mli b/src/irmin-pack/unix/store.mli index d7a17a25f7..7510aac381 100644 --- a/src/irmin-pack/unix/store.mli +++ b/src/irmin-pack/unix/store.mli @@ -17,4 +17,7 @@ include Store_intf.Sigs (** @inline *) -module Maker (Config : Irmin_pack.Conf.S) : Maker +module Maker + (Io : Io.S) + (Io_index : Index.Platform.S) + (Config : Irmin_pack.Conf.S) : Maker diff --git a/src/irmin-pack/unix/store_intf.ml b/src/irmin-pack/unix/store_intf.ml index 754cebc92a..e1bdd006b8 100644 --- a/src/irmin-pack/unix/store_intf.ml +++ b/src/irmin-pack/unix/store_intf.ml @@ -293,7 +293,7 @@ module type S = sig (** Unstable internal API agnostic about the underlying storage. Use it only to implement or test inodes. *) - module Io = Io.Unix + module Io : Io.S module Errs : Io_errors.S with module Io = Io module Index : Pack_index.S with type key = hash From dabb1fd7ddc83783810eae721162b932c553b32f Mon Sep 17 00:00:00 2001 From: ArthurW Date: Mon, 4 Sep 2023 21:42:47 +0200 Subject: [PATCH 73/99] upgrade to eio.0.12 --- src/irmin-fs/irmin_fs.ml | 12 ++++++------ src/irmin-fs/irmin_fs.mli | 6 +++--- src/irmin-fs/unix/irmin_fs_unix.ml | 4 ++-- src/irmin/conf.ml | 4 ++-- src/irmin/conf.mli | 8 ++++---- 5 files changed, 17 insertions(+), 17 deletions(-) diff --git a/src/irmin-fs/irmin_fs.ml b/src/irmin-fs/irmin_fs.ml index 4aceb32ca7..c08c50353e 100644 --- a/src/irmin-fs/irmin_fs.ml +++ b/src/irmin-fs/irmin_fs.ml @@ -25,13 +25,13 @@ module Log = (val Logs.src_log src : Logs.LOG) let ( / ) = Path.( / ) module type Config = sig - val dir : Fs.dir Path.t -> Fs.dir Path.t + val dir : Fs.dir_ty Path.t -> Fs.dir_ty Path.t val file_of_key : string -> string val key_of_file : string -> string end module type IO = sig - type path = Fs.dir Path.t + type path = Fs.dir_ty Path.t val rec_files : path -> path list val file_exists : path -> bool @@ -76,7 +76,7 @@ module Read_only_ext struct type key = K.t type value = V.t - type 'a t = { path : Fs.dir Path.t } + type 'a t = { path : Fs.dir_ty Path.t } let get_path config = Option.value Conf.(find_root config) ~default:"." @@ -332,12 +332,12 @@ end module IO_mem = struct type t = { watches : (string, string -> unit) Hashtbl.t; - files : (Fs.dir Path.t, string) Hashtbl.t; + files : (Fs.dir_ty Path.t, string) Hashtbl.t; } let t = { watches = Hashtbl.create 3; files = Hashtbl.create 13 } - type path = Fs.dir Path.t + type path = Fs.dir_ty Path.t type lock = Eio.Mutex.t let locks = Hashtbl.create 10 @@ -424,7 +424,7 @@ module Maker_is_a_maker : Irmin.Maker = Maker (IO_mem) (* Enforce that {!KV} is a sub-type of {!Irmin.KV_maker}. *) module KV_is_a_KV : Irmin.KV_maker = KV (IO_mem) -let run (fs : Fs.dir Path.t) fn = +let run (fs : Fs.dir_ty Path.t) fn = Switch.run @@ fun sw -> Irmin.Backend.Watch.set_watch_switch sw; let open Effect.Deep in diff --git a/src/irmin-fs/irmin_fs.mli b/src/irmin-fs/irmin_fs.mli index 65b3ba679e..a463246c6b 100644 --- a/src/irmin-fs/irmin_fs.mli +++ b/src/irmin-fs/irmin_fs.mli @@ -33,7 +33,7 @@ val config : string -> Irmin.config module type IO = sig (** {1 File-system abstractions} *) - type path = Eio.Fs.dir Eio.Path.t + type path = Eio.Fs.dir_ty Eio.Path.t (** The type for paths. *) (** {2 Read operations} *) @@ -86,7 +86,7 @@ module type Config = sig open Eio (** Same as [Config] but gives more control on the file hierarchy. *) - val dir : Fs.dir Path.t -> Fs.dir Path.t + val dir : Fs.dir_ty Path.t -> Fs.dir_ty Path.t (** [dir root] is the sub-directory to look for the keys. *) val file_of_key : string -> string @@ -109,4 +109,4 @@ module IO_mem : sig val set_listen_hook : unit -> unit end -val run : Eio.Fs.dir Eio.Path.t -> (unit -> 'a) -> 'a +val run : Eio.Fs.dir_ty Eio.Path.t -> (unit -> 'a) -> 'a diff --git a/src/irmin-fs/unix/irmin_fs_unix.ml b/src/irmin-fs/unix/irmin_fs_unix.ml index 6914a4a056..ef7253ad7b 100644 --- a/src/irmin-fs/unix/irmin_fs_unix.ml +++ b/src/irmin-fs/unix/irmin_fs_unix.ml @@ -121,7 +121,7 @@ module IO = struct Fun.protect fn ~finally:(fun () -> unlock f) end - type path = Eio.Fs.dir Eio.Path.t + type path = Eio.Fs.dir_ty Eio.Path.t (* we use file locking *) type lock = path @@ -271,7 +271,7 @@ module IO = struct in true) - let rec_files dir : Fs.dir Path.t list = + let rec_files dir : Fs.dir_ty Path.t list = let rec aux accu dir = let ds = directories dir in let fs = files dir in diff --git a/src/irmin/conf.ml b/src/irmin/conf.ml index f40adc9d5f..d66e810a12 100644 --- a/src/irmin/conf.ml +++ b/src/irmin/conf.ml @@ -181,8 +181,8 @@ let find_root (spec, d) : string option = module Env = struct type _ Effect.t += - | Fs : Eio.Fs.dir Eio.Path.t Effect.t - | Net : Eio.Net.t Effect.t + | Fs : Eio.Fs.dir_ty Eio.Path.t Effect.t + | Net : _ Eio.Net.t Effect.t let fs () = Effect.perform Fs let net () = Effect.perform Net diff --git a/src/irmin/conf.mli b/src/irmin/conf.mli index 23a98e49e2..c312c0b6d1 100644 --- a/src/irmin/conf.mli +++ b/src/irmin/conf.mli @@ -169,9 +169,9 @@ val find_root : t -> string option module Env : sig type _ Effect.t += - | Fs : Eio.Fs.dir Eio.Path.t Effect.t - | Net : Eio.Net.t Effect.t + | Fs : Eio.Fs.dir_ty Eio.Path.t Effect.t + | Net : _ Eio.Net.t Effect.t - val fs : unit -> Eio.Fs.dir Eio.Path.t - val net : unit -> Eio.Net.t + val fs : unit -> Eio.Fs.dir_ty Eio.Path.t + val net : unit -> _ Eio.Net.t end From 5f550c772e295fd54676cdcf906ecc3086214568 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Wed, 6 Sep 2023 16:47:20 +0200 Subject: [PATCH 74/99] irmin-pack: generic io lib without unix dependency --- .../{unix => io}/append_only_file.ml | 6 +- .../{unix => io}/append_only_file.mli | 0 .../{unix => io}/append_only_file_intf.ml | 4 +- src/irmin-pack/{unix => io}/async.ml | 0 src/irmin-pack/{unix => io}/async.mli | 0 src/irmin-pack/{unix => io}/async_intf.ml | 0 src/irmin-pack/{unix => io}/atomic_write.ml | 5 +- src/irmin-pack/{unix => io}/atomic_write.mli | 2 +- src/irmin-pack/{unix => io}/checks.ml | 7 +- src/irmin-pack/{unix => io}/checks.mli | 0 src/irmin-pack/{unix => io}/checks_intf.ml | 2 +- src/irmin-pack/{unix => io}/chunked_suffix.ml | 2 +- .../{unix => io}/chunked_suffix.mli | 0 .../{unix => io}/chunked_suffix_intf.ml | 4 +- src/irmin-pack/{unix => io}/control_file.ml | 6 +- src/irmin-pack/{unix => io}/control_file.mli | 0 .../{unix => io}/control_file_intf.ml | 6 +- src/irmin-pack/{unix => io}/dict.ml | 2 +- src/irmin-pack/{unix => io}/dict.mli | 0 src/irmin-pack/{unix => io}/dict_intf.ml | 4 +- src/irmin-pack/{unix => io}/dispatcher.ml | 0 src/irmin-pack/{unix => io}/dispatcher.mli | 0 .../{unix => io}/dispatcher_intf.ml | 0 src/irmin-pack/io/dune | 20 +++++ src/irmin-pack/{unix => io}/errors.ml | 0 src/irmin-pack/{unix => io}/file_manager.ml | 2 +- src/irmin-pack/{unix => io}/file_manager.mli | 0 .../{unix => io}/file_manager_intf.ml | 4 +- src/irmin-pack/{unix => io}/gc.ml | 0 src/irmin-pack/{unix => io}/gc.mli | 0 src/irmin-pack/{unix => io}/gc_args.ml | 0 src/irmin-pack/{unix => io}/gc_stats.ml | 0 src/irmin-pack/{unix => io}/gc_stats.mli | 0 src/irmin-pack/{unix => io}/gc_worker.ml | 0 src/irmin-pack/{unix => io}/gc_worker.mli | 0 src/irmin-pack/{unix => io}/import.ml | 0 src/irmin-pack/{unix => io}/inode.ml | 0 src/irmin-pack/{unix => io}/inode.mli | 0 src/irmin-pack/{unix => io}/inode_intf.ml | 0 src/irmin-pack/{unix => io}/io_errors.ml | 6 +- src/irmin-pack/{unix => io}/io_intf.ml | 0 src/irmin-pack/io/irmin_pack_io.ml | 73 +++++++++++++++++ src/irmin-pack/io/irmin_pack_io.mli | 81 +++++++++++++++++++ src/irmin-pack/{unix => io}/lower.ml | 5 +- src/irmin-pack/{unix => io}/lower.mli | 0 src/irmin-pack/{unix => io}/lower_intf.ml | 8 +- src/irmin-pack/{unix => io}/lru.ml | 0 src/irmin-pack/{unix => io}/lru.mli | 0 src/irmin-pack/{unix => io}/pack_index.ml | 24 +++--- src/irmin-pack/{unix => io}/pack_index.mli | 0 .../{unix => io}/pack_index_intf.ml | 15 ++-- src/irmin-pack/{unix => io}/pack_key.ml | 0 src/irmin-pack/{unix => io}/pack_key.mli | 0 src/irmin-pack/{unix => io}/pack_key_intf.ml | 0 src/irmin-pack/{unix => io}/pack_store.ml | 0 src/irmin-pack/{unix => io}/pack_store.mli | 0 .../{unix => io}/pack_store_intf.ml | 0 src/irmin-pack/{unix => io}/pack_value.ml | 0 src/irmin-pack/{unix => io}/ranges.ml | 0 src/irmin-pack/{unix => io}/ranges.mli | 0 src/irmin-pack/{unix => io}/snapshot.ml | 7 +- src/irmin-pack/{unix => io}/snapshot.mli | 0 src/irmin-pack/{unix => io}/snapshot_intf.ml | 4 +- src/irmin-pack/{unix => io}/sparse_file.ml | 4 +- src/irmin-pack/{unix => io}/sparse_file.mli | 0 .../{unix => io}/sparse_file_intf.ml | 4 +- src/irmin-pack/{unix => io}/stats.ml | 0 src/irmin-pack/{unix => io}/stats.mli | 0 src/irmin-pack/{unix => io}/stats_intf.ml | 0 src/irmin-pack/{unix => io}/store.ml | 3 +- src/irmin-pack/{unix => io}/store.mli | 2 +- src/irmin-pack/{unix => io}/store_intf.ml | 2 +- .../{unix => io}/traverse_pack_file.ml | 1 - src/irmin-pack/{unix => io}/utils.ml | 0 src/irmin-pack/unix/dune | 2 +- src/irmin-pack/unix/io.ml | 6 +- src/irmin-pack/unix/io.mli | 3 +- src/irmin-pack/unix/irmin_pack_unix.ml | 34 ++++---- src/irmin-pack/unix/irmin_pack_unix.mli | 24 +++--- test/irmin-pack/test_pack.mli | 4 +- 80 files changed, 282 insertions(+), 106 deletions(-) rename src/irmin-pack/{unix => io}/append_only_file.ml (96%) rename src/irmin-pack/{unix => io}/append_only_file.mli (100%) rename src/irmin-pack/{unix => io}/append_only_file_intf.ml (98%) rename src/irmin-pack/{unix => io}/async.ml (100%) rename src/irmin-pack/{unix => io}/async.mli (100%) rename src/irmin-pack/{unix => io}/async_intf.ml (100%) rename src/irmin-pack/{unix => io}/atomic_write.ml (98%) rename src/irmin-pack/{unix => io}/atomic_write.mli (92%) rename src/irmin-pack/{unix => io}/checks.ml (99%) rename src/irmin-pack/{unix => io}/checks.mli (100%) rename src/irmin-pack/{unix => io}/checks_intf.ml (98%) rename src/irmin-pack/{unix => io}/chunked_suffix.ml (99%) rename src/irmin-pack/{unix => io}/chunked_suffix.mli (100%) rename src/irmin-pack/{unix => io}/chunked_suffix_intf.ml (97%) rename src/irmin-pack/{unix => io}/control_file.ml (98%) rename src/irmin-pack/{unix => io}/control_file.mli (100%) rename src/irmin-pack/{unix => io}/control_file_intf.ml (98%) rename src/irmin-pack/{unix => io}/dict.ml (98%) rename src/irmin-pack/{unix => io}/dict.mli (100%) rename src/irmin-pack/{unix => io}/dict_intf.ml (95%) rename src/irmin-pack/{unix => io}/dispatcher.ml (100%) rename src/irmin-pack/{unix => io}/dispatcher.mli (100%) rename src/irmin-pack/{unix => io}/dispatcher_intf.ml (100%) create mode 100644 src/irmin-pack/io/dune rename src/irmin-pack/{unix => io}/errors.ml (100%) rename src/irmin-pack/{unix => io}/file_manager.ml (99%) rename src/irmin-pack/{unix => io}/file_manager.mli (100%) rename src/irmin-pack/{unix => io}/file_manager_intf.ml (99%) rename src/irmin-pack/{unix => io}/gc.ml (100%) rename src/irmin-pack/{unix => io}/gc.mli (100%) rename src/irmin-pack/{unix => io}/gc_args.ml (100%) rename src/irmin-pack/{unix => io}/gc_stats.ml (100%) rename src/irmin-pack/{unix => io}/gc_stats.mli (100%) rename src/irmin-pack/{unix => io}/gc_worker.ml (100%) rename src/irmin-pack/{unix => io}/gc_worker.mli (100%) rename src/irmin-pack/{unix => io}/import.ml (100%) rename src/irmin-pack/{unix => io}/inode.ml (100%) rename src/irmin-pack/{unix => io}/inode.mli (100%) rename src/irmin-pack/{unix => io}/inode_intf.ml (100%) rename src/irmin-pack/{unix => io}/io_errors.ml (96%) rename src/irmin-pack/{unix => io}/io_intf.ml (100%) create mode 100644 src/irmin-pack/io/irmin_pack_io.ml create mode 100644 src/irmin-pack/io/irmin_pack_io.mli rename src/irmin-pack/{unix => io}/lower.ml (98%) rename src/irmin-pack/{unix => io}/lower.mli (100%) rename src/irmin-pack/{unix => io}/lower_intf.ml (97%) rename src/irmin-pack/{unix => io}/lru.ml (100%) rename src/irmin-pack/{unix => io}/lru.mli (100%) rename src/irmin-pack/{unix => io}/pack_index.ml (88%) rename src/irmin-pack/{unix => io}/pack_index.mli (100%) rename src/irmin-pack/{unix => io}/pack_index_intf.ml (86%) rename src/irmin-pack/{unix => io}/pack_key.ml (100%) rename src/irmin-pack/{unix => io}/pack_key.mli (100%) rename src/irmin-pack/{unix => io}/pack_key_intf.ml (100%) rename src/irmin-pack/{unix => io}/pack_store.ml (100%) rename src/irmin-pack/{unix => io}/pack_store.mli (100%) rename src/irmin-pack/{unix => io}/pack_store_intf.ml (100%) rename src/irmin-pack/{unix => io}/pack_value.ml (100%) rename src/irmin-pack/{unix => io}/ranges.ml (100%) rename src/irmin-pack/{unix => io}/ranges.mli (100%) rename src/irmin-pack/{unix => io}/snapshot.ml (98%) rename src/irmin-pack/{unix => io}/snapshot.mli (100%) rename src/irmin-pack/{unix => io}/snapshot_intf.ml (95%) rename src/irmin-pack/{unix => io}/sparse_file.ml (99%) rename src/irmin-pack/{unix => io}/sparse_file.mli (100%) rename src/irmin-pack/{unix => io}/sparse_file_intf.ml (98%) rename src/irmin-pack/{unix => io}/stats.ml (100%) rename src/irmin-pack/{unix => io}/stats.mli (100%) rename src/irmin-pack/{unix => io}/stats_intf.ml (100%) rename src/irmin-pack/{unix => io}/store.ml (99%) rename src/irmin-pack/{unix => io}/store.mli (97%) rename src/irmin-pack/{unix => io}/store_intf.ml (99%) rename src/irmin-pack/{unix => io}/traverse_pack_file.ml (99%) rename src/irmin-pack/{unix => io}/utils.ml (100%) diff --git a/src/irmin-pack/unix/append_only_file.ml b/src/irmin-pack/io/append_only_file.ml similarity index 96% rename from src/irmin-pack/unix/append_only_file.ml rename to src/irmin-pack/io/append_only_file.ml index d3e45481bc..f8221f8207 100644 --- a/src/irmin-pack/unix/append_only_file.ml +++ b/src/irmin-pack/io/append_only_file.ml @@ -17,7 +17,7 @@ open Import include Append_only_file_intf -module Make (Io : Io.S) (Errs : Io_errors.S with module Io = Io) = struct +module Make (Io : Io_intf.S) (Errs : Io_errors.S with module Io = Io) = struct module Io = Io module Errs = Errs @@ -49,8 +49,6 @@ module Make (Io : Io.S) (Errs : Io_errors.S with module Io = Io) = struct let open Result_syntax in let+ io = Io.create ~path ~overwrite in let persisted_end_poff = Atomic.make Int63.zero in - let buf = Buffer.create 0 in - let buf_length = Atomic.make 0 in { io; persisted_end_poff; @@ -181,6 +179,6 @@ module Make (Io : Io.S) (Errs : Io_errors.S with module Io = Io) = struct Atomic.fetch_and_add rw_perm.buf_length (String.length s) in let buf_length = Atomic.get rw_perm.buf_length in - if buf_length >= rw_perm.auto_flush_threshold then + if buf_length >= auto_flush_threshold then flush t |> Errs.raise_if_error end diff --git a/src/irmin-pack/unix/append_only_file.mli b/src/irmin-pack/io/append_only_file.mli similarity index 100% rename from src/irmin-pack/unix/append_only_file.mli rename to src/irmin-pack/io/append_only_file.mli diff --git a/src/irmin-pack/unix/append_only_file_intf.ml b/src/irmin-pack/io/append_only_file_intf.ml similarity index 98% rename from src/irmin-pack/unix/append_only_file_intf.ml rename to src/irmin-pack/io/append_only_file_intf.ml index a7150bf939..41ae128a7a 100644 --- a/src/irmin-pack/unix/append_only_file_intf.ml +++ b/src/irmin-pack/io/append_only_file_intf.ml @@ -25,7 +25,7 @@ module type S = sig It comprises a persistent file, an append buffer and take care of automatically shifting offsets to deal with legacy file headers. *) - module Io : Io.S + module Io : Io_intf.S module Errs : Io_errors.S type t @@ -162,6 +162,6 @@ end module type Sigs = sig module type S = S - module Make (Io : Io.S) (Errs : Io_errors.S with module Io = Io) : + module Make (Io : Io_intf.S) (Errs : Io_errors.S with module Io = Io) : S with module Io = Io and module Errs = Errs end diff --git a/src/irmin-pack/unix/async.ml b/src/irmin-pack/io/async.ml similarity index 100% rename from src/irmin-pack/unix/async.ml rename to src/irmin-pack/io/async.ml diff --git a/src/irmin-pack/unix/async.mli b/src/irmin-pack/io/async.mli similarity index 100% rename from src/irmin-pack/unix/async.mli rename to src/irmin-pack/io/async.mli diff --git a/src/irmin-pack/unix/async_intf.ml b/src/irmin-pack/io/async_intf.ml similarity index 100% rename from src/irmin-pack/unix/async_intf.ml rename to src/irmin-pack/io/async_intf.ml diff --git a/src/irmin-pack/unix/atomic_write.ml b/src/irmin-pack/io/atomic_write.ml similarity index 98% rename from src/irmin-pack/unix/atomic_write.ml rename to src/irmin-pack/io/atomic_write.ml index e3c60704ed..fd613893f4 100644 --- a/src/irmin-pack/unix/atomic_write.ml +++ b/src/irmin-pack/io/atomic_write.ml @@ -1,8 +1,6 @@ open Import include Irmin_pack.Atomic_write -let current_version = `V1 - module UnsafeTbl (K : Irmin.Type.S) = Hashtbl.Make (struct type t = K.t [@@deriving irmin ~short_hash ~equal] @@ -44,7 +42,8 @@ module Table (K : Irmin.Type.S) = struct Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.fold f data init end -module Make_persistent (K : Irmin.Type.S) (V : Value.S) = struct +module Make_persistent (Io : Io_intf.S) (K : Irmin.Type.S) (V : Value.S) = +struct module Tbl = Table (K) module W = Irmin.Backend.Watch.Make (K) (V) module Io_errors = Io_errors.Make (Io) diff --git a/src/irmin-pack/unix/atomic_write.mli b/src/irmin-pack/io/atomic_write.mli similarity index 92% rename from src/irmin-pack/unix/atomic_write.mli rename to src/irmin-pack/io/atomic_write.mli index 8b7632959e..74bcfb0d22 100644 --- a/src/irmin-pack/unix/atomic_write.mli +++ b/src/irmin-pack/io/atomic_write.mli @@ -17,5 +17,5 @@ open! Import include module type of Irmin_pack.Atomic_write -module Make_persistent (Io : Io.S) (K : Irmin.Type.S) (V : Value.S) : +module Make_persistent (Io : Io_intf.S) (K : Irmin.Type.S) (V : Value.S) : Persistent with type key = K.t and type value = V.t diff --git a/src/irmin-pack/unix/checks.ml b/src/irmin-pack/io/checks.ml similarity index 99% rename from src/irmin-pack/unix/checks.ml rename to src/irmin-pack/io/checks.ml index 52365bbe46..1f1a96bdc3 100644 --- a/src/irmin-pack/unix/checks.ml +++ b/src/irmin-pack/io/checks.ml @@ -61,11 +61,10 @@ let ppf_or_null ppf = | Some p -> p | None -> open_out null |> Format.formatter_of_out_channel -module Make (Store : Store) = struct +module Make (Io : Io_intf.S) (Io_index : Index.Platform.S) (Store : Store) = +struct module Hash = Store.Hash - - module Index = - Pack_index.Make_io (Io.Unix) (Index_unix.Private.Platform) (Hash) + module Index = Pack_index.Make_io (Io) (Io_index) (Hash) (** Read basic metrics from an existing store. *) module Stat = struct diff --git a/src/irmin-pack/unix/checks.mli b/src/irmin-pack/io/checks.mli similarity index 100% rename from src/irmin-pack/unix/checks.mli rename to src/irmin-pack/io/checks.mli diff --git a/src/irmin-pack/unix/checks_intf.ml b/src/irmin-pack/io/checks_intf.ml similarity index 98% rename from src/irmin-pack/unix/checks_intf.ml rename to src/irmin-pack/io/checks_intf.ml index 828b65d341..4681f300d1 100644 --- a/src/irmin-pack/unix/checks_intf.ml +++ b/src/irmin-pack/io/checks_intf.ml @@ -131,7 +131,7 @@ module type Sigs = sig module type Subcommand = Subcommand module type S = S - module Make (_ : Store) : S + module Make (Io : Io_intf.S) (Io_index : Index.Platform.S) (_ : Store) : S module Integrity_checks (XKey : Pack_key.S) diff --git a/src/irmin-pack/unix/chunked_suffix.ml b/src/irmin-pack/io/chunked_suffix.ml similarity index 99% rename from src/irmin-pack/unix/chunked_suffix.ml rename to src/irmin-pack/io/chunked_suffix.ml index e674e17fec..c8172e03f8 100644 --- a/src/irmin-pack/unix/chunked_suffix.ml +++ b/src/irmin-pack/io/chunked_suffix.ml @@ -17,7 +17,7 @@ open Import include Chunked_suffix_intf -module Make (Io : Io.S) (Errs : Io_errors.S with module Io = Io) = struct +module Make (Io : Io_intf.S) (Errs : Io_errors.S with module Io = Io) = struct module Io = Io module Errs = Errs module Ao = Append_only_file.Make (Io) (Errs) diff --git a/src/irmin-pack/unix/chunked_suffix.mli b/src/irmin-pack/io/chunked_suffix.mli similarity index 100% rename from src/irmin-pack/unix/chunked_suffix.mli rename to src/irmin-pack/io/chunked_suffix.mli diff --git a/src/irmin-pack/unix/chunked_suffix_intf.ml b/src/irmin-pack/io/chunked_suffix_intf.ml similarity index 97% rename from src/irmin-pack/unix/chunked_suffix_intf.ml rename to src/irmin-pack/io/chunked_suffix_intf.ml index b037dc5f74..09ad711ce0 100644 --- a/src/irmin-pack/unix/chunked_suffix_intf.ml +++ b/src/irmin-pack/io/chunked_suffix_intf.ml @@ -25,7 +25,7 @@ module type S = sig - [start_idx] and [chunk_num] for the open functions to know the starting file name and how many files there are. *) - module Io : Io.S + module Io : Io_intf.S module Errs : Io_errors.S module Ao : Append_only_file.S @@ -126,6 +126,6 @@ end module type Sigs = sig module type S = S - module Make (Io : Io.S) (Errs : Io_errors.S with module Io = Io) : + module Make (Io : Io_intf.S) (Errs : Io_errors.S with module Io = Io) : S with module Io = Io and module Errs = Errs end diff --git a/src/irmin-pack/unix/control_file.ml b/src/irmin-pack/io/control_file.ml similarity index 98% rename from src/irmin-pack/unix/control_file.ml rename to src/irmin-pack/io/control_file.ml index 2eab42867a..0e88b66175 100644 --- a/src/irmin-pack/unix/control_file.ml +++ b/src/irmin-pack/io/control_file.ml @@ -70,9 +70,7 @@ module Serde = struct match Version.of_bin left with | None -> Error (`Unknown_major_pack_version left) | Some (`V1 | `V2) -> assert false (* TODO: create specific error *) - | Some ((`V3 | `V4 | `V5) as x) -> - if len > Io.Unix.page_size then Error (`Corrupted_control_file ctx) - else Ok x + | Some ((`V3 | `V4 | `V5) as x) -> Ok x in (version, right) @@ -317,7 +315,7 @@ module Serde = struct end end -module Make (Serde : Serde.S) (Io : Io.S) = struct +module Make (Serde : Serde.S) (Io : Io_intf.S) = struct module Io = Io type payload = Serde.payload diff --git a/src/irmin-pack/unix/control_file.mli b/src/irmin-pack/io/control_file.mli similarity index 100% rename from src/irmin-pack/unix/control_file.mli rename to src/irmin-pack/io/control_file.mli diff --git a/src/irmin-pack/unix/control_file_intf.ml b/src/irmin-pack/io/control_file_intf.ml similarity index 98% rename from src/irmin-pack/unix/control_file_intf.ml rename to src/irmin-pack/io/control_file_intf.ml index 7ce02130e2..d33fac8185 100644 --- a/src/irmin-pack/unix/control_file_intf.ml +++ b/src/irmin-pack/io/control_file_intf.ml @@ -297,7 +297,7 @@ module type S = sig None of the functions raise exceptions. *) - module Io : Io.S + module Io : Io_intf.S type payload type raw_payload @@ -418,6 +418,6 @@ module type Sigs = sig module type Upper = Upper module type Volume = Volume - module Upper (Io : Io.S) : Upper with module Io = Io - module Volume (Io : Io.S) : Volume with module Io = Io + module Upper (Io : Io_intf.S) : Upper with module Io = Io + module Volume (Io : Io_intf.S) : Volume with module Io = Io end diff --git a/src/irmin-pack/unix/dict.ml b/src/irmin-pack/io/dict.ml similarity index 98% rename from src/irmin-pack/unix/dict.ml rename to src/irmin-pack/io/dict.ml index 023c32323c..522678cfa1 100644 --- a/src/irmin-pack/unix/dict.ml +++ b/src/irmin-pack/io/dict.ml @@ -17,7 +17,7 @@ open! Import include Dict_intf -module Make (Io : Io.S) = struct +module Make (Io : Io_intf.S) = struct module Io = Io module Errs = Io_errors.Make (Io) module Ao = Append_only_file.Make (Io) (Errs) diff --git a/src/irmin-pack/unix/dict.mli b/src/irmin-pack/io/dict.mli similarity index 100% rename from src/irmin-pack/unix/dict.mli rename to src/irmin-pack/io/dict.mli diff --git a/src/irmin-pack/unix/dict_intf.ml b/src/irmin-pack/io/dict_intf.ml similarity index 95% rename from src/irmin-pack/unix/dict_intf.ml rename to src/irmin-pack/io/dict_intf.ml index 42a65d8436..0542b253a6 100644 --- a/src/irmin-pack/unix/dict_intf.ml +++ b/src/irmin-pack/io/dict_intf.ml @@ -17,7 +17,7 @@ open! Import module type S = sig - module Io : Io.S + module Io : Io_intf.S type t @@ -52,5 +52,5 @@ end module type Sigs = sig module type S = S - module Make (Io : Io.S) : S with module Io = Io + module Make (Io : Io_intf.S) : S with module Io = Io end diff --git a/src/irmin-pack/unix/dispatcher.ml b/src/irmin-pack/io/dispatcher.ml similarity index 100% rename from src/irmin-pack/unix/dispatcher.ml rename to src/irmin-pack/io/dispatcher.ml diff --git a/src/irmin-pack/unix/dispatcher.mli b/src/irmin-pack/io/dispatcher.mli similarity index 100% rename from src/irmin-pack/unix/dispatcher.mli rename to src/irmin-pack/io/dispatcher.mli diff --git a/src/irmin-pack/unix/dispatcher_intf.ml b/src/irmin-pack/io/dispatcher_intf.ml similarity index 100% rename from src/irmin-pack/unix/dispatcher_intf.ml rename to src/irmin-pack/io/dispatcher_intf.ml diff --git a/src/irmin-pack/io/dune b/src/irmin-pack/io/dune new file mode 100644 index 0000000000..ae24701c34 --- /dev/null +++ b/src/irmin-pack/io/dune @@ -0,0 +1,20 @@ +(library + (public_name irmin-pack.io) + (name irmin_pack_io) + (libraries + fmt + index + irmin + irmin-pack + logs + eio + mtime + cmdliner + optint + checkseum + checkseum.ocaml + rusage) + (preprocess + (pps ppx_irmin.internal)) + (instrumentation + (backend bisect_ppx))) diff --git a/src/irmin-pack/unix/errors.ml b/src/irmin-pack/io/errors.ml similarity index 100% rename from src/irmin-pack/unix/errors.ml rename to src/irmin-pack/io/errors.ml diff --git a/src/irmin-pack/unix/file_manager.ml b/src/irmin-pack/io/file_manager.ml similarity index 99% rename from src/irmin-pack/unix/file_manager.ml rename to src/irmin-pack/io/file_manager.ml index d73044ab5e..1386e1ef66 100644 --- a/src/irmin-pack/unix/file_manager.ml +++ b/src/irmin-pack/io/file_manager.ml @@ -21,7 +21,7 @@ include File_manager_intf let legacy_io_header_size = 16 module Make - (Io : Io.S) + (Io : Io_intf.S) (Index : Pack_index.S with module Io = Io) (Errs : Io_errors.S with module Io = Io) = struct diff --git a/src/irmin-pack/unix/file_manager.mli b/src/irmin-pack/io/file_manager.mli similarity index 100% rename from src/irmin-pack/unix/file_manager.mli rename to src/irmin-pack/io/file_manager.mli diff --git a/src/irmin-pack/unix/file_manager_intf.ml b/src/irmin-pack/io/file_manager_intf.ml similarity index 99% rename from src/irmin-pack/unix/file_manager_intf.ml rename to src/irmin-pack/io/file_manager_intf.ml index b43ade9567..7a567f9a6e 100644 --- a/src/irmin-pack/unix/file_manager_intf.ml +++ b/src/irmin-pack/io/file_manager_intf.ml @@ -58,7 +58,7 @@ module type S = sig 3. and 5. are highly critical. *) - module Io : Io.S + module Io : Io_intf.S module Control : Control_file.Upper with module Io = Io module Dict : Dict.S with module Io = Io module Suffix : Chunked_suffix.S with module Io = Io @@ -303,7 +303,7 @@ module type Sigs = sig module type S = S module Make - (Io : Io.S) + (Io : Io_intf.S) (Index : Pack_index.S with module Io = Io) (Errs : Io_errors.S with module Io = Io) : S with module Io = Io and module Index = Index and module Errs = Errs diff --git a/src/irmin-pack/unix/gc.ml b/src/irmin-pack/io/gc.ml similarity index 100% rename from src/irmin-pack/unix/gc.ml rename to src/irmin-pack/io/gc.ml diff --git a/src/irmin-pack/unix/gc.mli b/src/irmin-pack/io/gc.mli similarity index 100% rename from src/irmin-pack/unix/gc.mli rename to src/irmin-pack/io/gc.mli diff --git a/src/irmin-pack/unix/gc_args.ml b/src/irmin-pack/io/gc_args.ml similarity index 100% rename from src/irmin-pack/unix/gc_args.ml rename to src/irmin-pack/io/gc_args.ml diff --git a/src/irmin-pack/unix/gc_stats.ml b/src/irmin-pack/io/gc_stats.ml similarity index 100% rename from src/irmin-pack/unix/gc_stats.ml rename to src/irmin-pack/io/gc_stats.ml diff --git a/src/irmin-pack/unix/gc_stats.mli b/src/irmin-pack/io/gc_stats.mli similarity index 100% rename from src/irmin-pack/unix/gc_stats.mli rename to src/irmin-pack/io/gc_stats.mli diff --git a/src/irmin-pack/unix/gc_worker.ml b/src/irmin-pack/io/gc_worker.ml similarity index 100% rename from src/irmin-pack/unix/gc_worker.ml rename to src/irmin-pack/io/gc_worker.ml diff --git a/src/irmin-pack/unix/gc_worker.mli b/src/irmin-pack/io/gc_worker.mli similarity index 100% rename from src/irmin-pack/unix/gc_worker.mli rename to src/irmin-pack/io/gc_worker.mli diff --git a/src/irmin-pack/unix/import.ml b/src/irmin-pack/io/import.ml similarity index 100% rename from src/irmin-pack/unix/import.ml rename to src/irmin-pack/io/import.ml diff --git a/src/irmin-pack/unix/inode.ml b/src/irmin-pack/io/inode.ml similarity index 100% rename from src/irmin-pack/unix/inode.ml rename to src/irmin-pack/io/inode.ml diff --git a/src/irmin-pack/unix/inode.mli b/src/irmin-pack/io/inode.mli similarity index 100% rename from src/irmin-pack/unix/inode.mli rename to src/irmin-pack/io/inode.mli diff --git a/src/irmin-pack/unix/inode_intf.ml b/src/irmin-pack/io/inode_intf.ml similarity index 100% rename from src/irmin-pack/unix/inode_intf.ml rename to src/irmin-pack/io/inode_intf.ml diff --git a/src/irmin-pack/unix/io_errors.ml b/src/irmin-pack/io/io_errors.ml similarity index 96% rename from src/irmin-pack/unix/io_errors.ml rename to src/irmin-pack/io/io_errors.ml index 51c939e53b..ab49311805 100644 --- a/src/irmin-pack/unix/io_errors.ml +++ b/src/irmin-pack/io/io_errors.ml @@ -18,9 +18,9 @@ open Import open Errors (** Error manager for errors and exceptions defined in {!Errors} and - {!Io.S.misc_error} *) + {!Io_intf.S.misc_error} *) module type S = sig - module Io : Io.S + module Io : Io_intf.S type t = [ Base.t | `Io_misc of Io.misc_error ] [@@deriving irmin] @@ -31,7 +31,7 @@ module type S = sig val log_if_error : string -> ('a, [< t ]) result -> unit end -module Make (Io : Io.S) : S with module Io = Io = struct +module Make (Io : Io_intf.S) : S with module Io = Io = struct module Io = Io (* Inline the definition of the polymorphic variant for the ppx. *) diff --git a/src/irmin-pack/unix/io_intf.ml b/src/irmin-pack/io/io_intf.ml similarity index 100% rename from src/irmin-pack/unix/io_intf.ml rename to src/irmin-pack/io/io_intf.ml diff --git a/src/irmin-pack/io/irmin_pack_io.ml b/src/irmin-pack/io/irmin_pack_io.ml new file mode 100644 index 0000000000..102a30fbf0 --- /dev/null +++ b/src/irmin-pack/io/irmin_pack_io.ml @@ -0,0 +1,73 @@ +(* + * 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. + *) + +(** {1 Store} *) + +module type S = Store_intf.S +module type Io_s = Io_intf.S + +module Store_intf = Store_intf +module Maker_io = Store.Maker + +module KV + (Io : Io_intf.S) + (Index_io : Index.Platform.S) + (Config : Irmin_pack.Conf.S) = +struct + type endpoint = unit + type hash = Irmin.Schema.default_hash + + include Pack_key.Store_spec + module Maker = Store.Maker (Io) (Index_io) (Config) + + type metadata = Irmin.Metadata.None.t + + module Make (C : Irmin.Contents.S) = Maker.Make (Irmin.Schema.KV (C)) +end + +(** {1 Key and Values} *) + +module Pack_key = Pack_key +module Pack_value = Pack_value + +(** {1 Internal} *) + +module Stats = Stats +module Index = Pack_index +module Inode = Inode +module Pack_store = Pack_store +module Checks = Checks +module Checks_intf = Checks_intf +module Atomic_write = Atomic_write +module Dict = Dict +module Dispatcher = Dispatcher +module Async = Async +module Errors = Errors +module Io_errors = Io_errors +module Control_file = Control_file +module Control_file_intf = Control_file_intf +module Append_only_file = Append_only_file +module Chunked_suffix = Chunked_suffix +module Ranges = Ranges +module Sparse_file = Sparse_file +module File_manager = File_manager +module Lower = Lower +module Utils = Utils +module Lru = Lru +module Gc_raw = Gc +module Traverse_pack_file = Traverse_pack_file +module Snapshot = Snapshot +module Import = Import diff --git a/src/irmin-pack/io/irmin_pack_io.mli b/src/irmin-pack/io/irmin_pack_io.mli new file mode 100644 index 0000000000..813ee59ed0 --- /dev/null +++ b/src/irmin-pack/io/irmin_pack_io.mli @@ -0,0 +1,81 @@ +(* + * 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. + *) + +(** The [irmin-pack-unix] package provides an implementation of {!Irmin_pack} + for Unix systems. + + [irmin-pack-unix] provides advanced features such as garbage collection, + snapshoting, integrity checks. *) + +(** {1 Store} *) + +module type S = Store.S +module type Io_s = Io_intf.S + +module Store_intf = Store_intf + +module Maker_io + (Io : Io_intf.S) + (Io_index : Index.Platform.S) + (Config : Irmin_pack.Conf.S) : Store.Maker + +module KV + (Io : Io_intf.S) + (Io_index : Index.Platform.S) + (Config : Irmin_pack.Conf.S) : Store.KV + +(** {1 Key and Values} *) + +module Pack_key = Pack_key +module Pack_value = Pack_value + +(** {1 Integrity Checks} *) + +module Checks = Checks +module Checks_intf = Checks_intf + +(** {1 Statistics} *) + +module Stats = Stats + +(** {1 Internal Functors and Utilities} *) + +(** Following functors and modules are instantiated automatically or used + internally when creating a store with {!Maker} or {!KV}.*) + +module Index = Pack_index +module Inode = Inode +module Pack_store = Pack_store +module Atomic_write = Atomic_write +module Dict = Dict +module Dispatcher = Dispatcher +module Async = Async +module Errors = Errors +module Io_errors = Io_errors +module Control_file = Control_file +module Control_file_intf = Control_file_intf +module Append_only_file = Append_only_file +module Chunked_suffix = Chunked_suffix +module Ranges = Ranges +module Sparse_file = Sparse_file +module File_manager = File_manager +module Lower = Lower +module Utils = Utils +module Lru = Lru +module Gc_raw = Gc +module Traverse_pack_file = Traverse_pack_file +module Snapshot = Snapshot +module Import = Import diff --git a/src/irmin-pack/unix/lower.ml b/src/irmin-pack/io/lower.ml similarity index 98% rename from src/irmin-pack/unix/lower.ml rename to src/irmin-pack/io/lower.ml index e36f6a1f82..5b884bce82 100644 --- a/src/irmin-pack/unix/lower.ml +++ b/src/irmin-pack/io/lower.ml @@ -19,7 +19,8 @@ include Lower_intf module Layout = Irmin_pack.Layout.V5.Volume module Payload = Control_file.Payload.Volume.Latest -module Make_volume (Io : Io.S) (Errs : Io_errors.S with module Io = Io) = struct +module Make_volume (Io : Io_intf.S) (Errs : Io_errors.S with module Io = Io) = +struct module Io = Io module Errs = Errs module Control = Control_file.Volume (Io) @@ -252,7 +253,7 @@ module Make_volume (Io : Io.S) (Errs : Io_errors.S with module Io = Io) = struct path t |> Sys.readdir |> Array.to_list |> List.iter_result clean end -module Make (Io : Io.S) (Errs : Io_errors.S with module Io = Io) = struct +module Make (Io : Io_intf.S) (Errs : Io_errors.S with module Io = Io) = struct module Io = Io module Errs = Errs module Volume = Make_volume (Io) (Errs) diff --git a/src/irmin-pack/unix/lower.mli b/src/irmin-pack/io/lower.mli similarity index 100% rename from src/irmin-pack/unix/lower.mli rename to src/irmin-pack/io/lower.mli diff --git a/src/irmin-pack/unix/lower_intf.ml b/src/irmin-pack/io/lower_intf.ml similarity index 97% rename from src/irmin-pack/unix/lower_intf.ml rename to src/irmin-pack/io/lower_intf.ml index 1103181711..88972cabac 100644 --- a/src/irmin-pack/unix/lower_intf.ml +++ b/src/irmin-pack/io/lower_intf.ml @@ -19,7 +19,7 @@ open! Import type volume_identifier = string [@@deriving irmin] module type Volume = sig - module Io : Io.S + module Io : Io_intf.S module Errs : Io_errors.S module Sparse : Sparse_file.S @@ -49,7 +49,7 @@ module type Volume = sig end module type S = sig - module Io : Io.S + module Io : Io_intf.S module Errs : Io_errors.S module Volume : Volume with module Io = Io @@ -183,9 +183,9 @@ module type Sigs = sig type nonrec volume_identifier = volume_identifier [@@deriving irmin] - module Make_volume (Io : Io.S) (Errs : Io_errors.S with module Io = Io) : + module Make_volume (Io : Io_intf.S) (Errs : Io_errors.S with module Io = Io) : Volume with module Io = Io and module Errs = Errs - module Make (Io : Io.S) (Errs : Io_errors.S with module Io = Io) : + module Make (Io : Io_intf.S) (Errs : Io_errors.S with module Io = Io) : S with module Io = Io and module Errs = Errs end diff --git a/src/irmin-pack/unix/lru.ml b/src/irmin-pack/io/lru.ml similarity index 100% rename from src/irmin-pack/unix/lru.ml rename to src/irmin-pack/io/lru.ml diff --git a/src/irmin-pack/unix/lru.mli b/src/irmin-pack/io/lru.mli similarity index 100% rename from src/irmin-pack/unix/lru.mli rename to src/irmin-pack/io/lru.mli diff --git a/src/irmin-pack/unix/pack_index.ml b/src/irmin-pack/io/pack_index.ml similarity index 88% rename from src/irmin-pack/unix/pack_index.ml rename to src/irmin-pack/io/pack_index.ml index c8bdb225a6..4a2a763839 100644 --- a/src/irmin-pack/unix/pack_index.ml +++ b/src/irmin-pack/io/pack_index.ml @@ -18,7 +18,7 @@ open! Import include Pack_index_intf -module Make_io (Io : Io.S) (Io_index : Index.Platform.S) (K : Irmin.Hash.S) = +module Make_io (Io : Io_intf.S) (Io_index : Index.Platform.S) (K : Irmin.Hash.S) = struct module Key = struct type t = K.t @@ -61,13 +61,13 @@ struct module Stats = Index.Stats module I = Index - module Index = Index.Make (Key) (Val) (Io_index) (Index.Cache.Unbounded) - include Index + module Index_raw = Index.Make (Key) (Val) (Io_index) (Index.Cache.Unbounded) + include Index_raw module Io = Io let v_exn = let cache = None in - Index.v ?cache + Index_raw.v ?cache let v ?flush_callback ?fresh ?readonly ?throttle ?lru_size ~log_size root = try @@ -78,18 +78,20 @@ struct | I.RO_not_allowed -> (* Happens when [fresh = true = readonly] *) assert false + (* | Index_unix.Private.Raw.Not_written -> (* This is not expected to be raised but let's catch anyway to trigger a more precise error instead (i.e. the [assert false] below). This error is expected to be raised when a RO instance attemps an opening on a non-existing file. *) assert false + *) (* | Unix.Unix_error (x, y, z) -> Error (`Io_misc (x, y, z)) *) | Failure msg -> Error (`Index_failure msg) let add ?overcommit t k v = replace ?overcommit t k v let find t k = match find t k with exception Not_found -> None | h -> Some h - let close_exn t = Index.close t + let close_exn t = Index_raw.close t let close t = try @@ -97,29 +99,27 @@ struct Ok () with | I.RO_not_allowed -> Error `Ro_not_allowed - | Index_unix.Private.Raw.Not_written -> assert false + (* | Index_unix.Private.Raw.Not_written -> assert false *) (* | Unix.Unix_error (x, y, z) -> Error (`Io_misc (x, y, z)) *) | Failure msg -> Error (`Index_failure msg) let reload t = try - Index.sync t; + Index_raw.sync t; Ok () with | I.RO_not_allowed -> Error `Ro_not_allowed - | Index_unix.Private.Raw.Not_written -> assert false + (* | Index_unix.Private.Raw.Not_written -> assert false *) (* | Unix.Unix_error (x, y, z) -> Error (`Io_misc (x, y, z)) *) | Failure msg -> Error (`Index_failure msg) let flush t ~with_fsync = try - Index.flush ~no_callback:() ~with_fsync t; + Index_raw.flush ~no_callback:() ~with_fsync t; Ok () with | I.RO_not_allowed -> Error `Ro_not_allowed - | Index_unix.Private.Raw.Not_written -> assert false + (* | Index_unix.Private.Raw.Not_written -> assert false *) (* | Unix.Unix_error (x, y, z) -> Error (`Io_misc (x, y, z)) *) | Failure msg -> Error (`Index_failure msg) end - -module Make = Make_io (Io.Unix) (Index_unix.Private.Platform) diff --git a/src/irmin-pack/unix/pack_index.mli b/src/irmin-pack/io/pack_index.mli similarity index 100% rename from src/irmin-pack/unix/pack_index.mli rename to src/irmin-pack/io/pack_index.mli diff --git a/src/irmin-pack/unix/pack_index_intf.ml b/src/irmin-pack/io/pack_index_intf.ml similarity index 86% rename from src/irmin-pack/unix/pack_index_intf.ml rename to src/irmin-pack/io/pack_index_intf.ml index 4f15380de8..f06471b442 100644 --- a/src/irmin-pack/unix/pack_index_intf.ml +++ b/src/irmin-pack/io/pack_index_intf.ml @@ -24,8 +24,10 @@ module type S = sig type key type value = int63 * int * Pack_value.Kind.t - include Index.S with type value := value and type t := t and type key := key - module Io : Io.S + module Index_raw : + Index.S with type value := value and type t := t and type key := key + + module Io : Io_intf.S val v_exn : ?flush_callback:(unit -> unit) -> @@ -64,15 +66,14 @@ module type S = sig val filter : t -> (key * value -> bool) -> unit val try_merge : t -> unit - module Stats = Index.Stats module Key : Index.Key.S with type t = key end module type Sigs = sig module type S = S - module Make_io (Io : Io.S) (Io_index : Index.Platform.S) (K : Irmin.Hash.S) : - S with type key = K.t and module Io = Io - - module Make (K : Irmin.Hash.S) : S with type key = K.t and module Io = Io.Unix + module Make_io + (Io : Io_intf.S) + (Io_index : Index.Platform.S) + (K : Irmin.Hash.S) : S with type key = K.t and module Io = Io end diff --git a/src/irmin-pack/unix/pack_key.ml b/src/irmin-pack/io/pack_key.ml similarity index 100% rename from src/irmin-pack/unix/pack_key.ml rename to src/irmin-pack/io/pack_key.ml diff --git a/src/irmin-pack/unix/pack_key.mli b/src/irmin-pack/io/pack_key.mli similarity index 100% rename from src/irmin-pack/unix/pack_key.mli rename to src/irmin-pack/io/pack_key.mli diff --git a/src/irmin-pack/unix/pack_key_intf.ml b/src/irmin-pack/io/pack_key_intf.ml similarity index 100% rename from src/irmin-pack/unix/pack_key_intf.ml rename to src/irmin-pack/io/pack_key_intf.ml diff --git a/src/irmin-pack/unix/pack_store.ml b/src/irmin-pack/io/pack_store.ml similarity index 100% rename from src/irmin-pack/unix/pack_store.ml rename to src/irmin-pack/io/pack_store.ml diff --git a/src/irmin-pack/unix/pack_store.mli b/src/irmin-pack/io/pack_store.mli similarity index 100% rename from src/irmin-pack/unix/pack_store.mli rename to src/irmin-pack/io/pack_store.mli diff --git a/src/irmin-pack/unix/pack_store_intf.ml b/src/irmin-pack/io/pack_store_intf.ml similarity index 100% rename from src/irmin-pack/unix/pack_store_intf.ml rename to src/irmin-pack/io/pack_store_intf.ml diff --git a/src/irmin-pack/unix/pack_value.ml b/src/irmin-pack/io/pack_value.ml similarity index 100% rename from src/irmin-pack/unix/pack_value.ml rename to src/irmin-pack/io/pack_value.ml diff --git a/src/irmin-pack/unix/ranges.ml b/src/irmin-pack/io/ranges.ml similarity index 100% rename from src/irmin-pack/unix/ranges.ml rename to src/irmin-pack/io/ranges.ml diff --git a/src/irmin-pack/unix/ranges.mli b/src/irmin-pack/io/ranges.mli similarity index 100% rename from src/irmin-pack/unix/ranges.mli rename to src/irmin-pack/io/ranges.mli diff --git a/src/irmin-pack/unix/snapshot.ml b/src/irmin-pack/io/snapshot.ml similarity index 98% rename from src/irmin-pack/unix/snapshot.ml rename to src/irmin-pack/io/snapshot.ml index b9c8413f42..87cfe4675b 100644 --- a/src/irmin-pack/unix/snapshot.ml +++ b/src/irmin-pack/io/snapshot.ml @@ -28,7 +28,7 @@ module Make (Args : Args) = struct module Hashes = Irmin.Hash.Set.Make (Args.Hash) open Args module Inode_pack = Inode.Pack - module Pack_index = Pack_index.Make (Hash) + module Pack_index = Fm.Index let pp_hash = Irmin.Type.pp Hash.t let pp_key = Irmin.Type.pp Inode_pack.Key.t @@ -45,7 +45,8 @@ module Make (Args : Args) = struct end module Index = - Index_unix.Make (Pack_index.Key) (Value_unit) (Index.Cache.Unbounded) + Index.Make (Pack_index.Key) (Value_unit) (Io_index) + (Index.Cache.Unbounded) type t = { fm : Fm.t; @@ -243,7 +244,7 @@ module Make (Args : Args) = struct end module Index = - Index_unix.Make (Pack_index.Key) (Value) (Index.Cache.Unbounded) + Index.Make (Pack_index.Key) (Value) (Io_index) (Index.Cache.Unbounded) type path = string diff --git a/src/irmin-pack/unix/snapshot.mli b/src/irmin-pack/io/snapshot.mli similarity index 100% rename from src/irmin-pack/unix/snapshot.mli rename to src/irmin-pack/io/snapshot.mli diff --git a/src/irmin-pack/unix/snapshot_intf.ml b/src/irmin-pack/io/snapshot_intf.ml similarity index 95% rename from src/irmin-pack/unix/snapshot_intf.ml rename to src/irmin-pack/io/snapshot_intf.ml index d3e2bd828a..3815d103cc 100644 --- a/src/irmin-pack/unix/snapshot_intf.ml +++ b/src/irmin-pack/io/snapshot_intf.ml @@ -18,7 +18,7 @@ open! Import module type Args = sig module Hash : Irmin.Hash.S - module Fm : File_manager.S + module Fm : File_manager.S with type Index.key = Hash.t module Dispatcher : Dispatcher.S with module Fm = Fm module Inode : @@ -33,6 +33,8 @@ module type Args = sig with type hash := Hash.t and type key = Hash.t Pack_key.t and type dispatcher = Dispatcher.t + + module Io_index : Index.Platform.S end module type Sigs = sig diff --git a/src/irmin-pack/unix/sparse_file.ml b/src/irmin-pack/io/sparse_file.ml similarity index 99% rename from src/irmin-pack/unix/sparse_file.ml rename to src/irmin-pack/io/sparse_file.ml index 44657ead61..d41034ebaa 100644 --- a/src/irmin-pack/unix/sparse_file.ml +++ b/src/irmin-pack/io/sparse_file.ml @@ -20,7 +20,7 @@ module BigArr1 = Bigarray.Array1 type int64_bigarray = (int64, Bigarray.int64_elt, Bigarray.c_layout) BigArr1.t -module Int64_mmap (Io : Io.S) : sig +module Int64_mmap (Io : Io_intf.S) : sig type t val open_ro : fn:string -> sz:int -> (t, [> Io.open_error ]) result @@ -70,7 +70,7 @@ end = struct t.arr.{i} end -module Make (Io : Io.S) = struct +module Make (Io : Io_intf.S) = struct module Io = Io module Errs = Io_errors.Make (Io) diff --git a/src/irmin-pack/unix/sparse_file.mli b/src/irmin-pack/io/sparse_file.mli similarity index 100% rename from src/irmin-pack/unix/sparse_file.mli rename to src/irmin-pack/io/sparse_file.mli diff --git a/src/irmin-pack/unix/sparse_file_intf.ml b/src/irmin-pack/io/sparse_file_intf.ml similarity index 98% rename from src/irmin-pack/unix/sparse_file_intf.ml rename to src/irmin-pack/io/sparse_file_intf.ml index 83840512de..4e335f53d7 100644 --- a/src/irmin-pack/unix/sparse_file_intf.ml +++ b/src/irmin-pack/io/sparse_file_intf.ml @@ -17,7 +17,7 @@ open! Import module type S = sig - module Io : Io.S + module Io : Io_intf.S module Errs : Io_errors.S with module Io = Io type t @@ -153,5 +153,5 @@ end module type Sigs = sig module type S = S - module Make (Io : Io.S) : S with module Io = Io + module Make (Io : Io_intf.S) : S with module Io = Io end diff --git a/src/irmin-pack/unix/stats.ml b/src/irmin-pack/io/stats.ml similarity index 100% rename from src/irmin-pack/unix/stats.ml rename to src/irmin-pack/io/stats.ml diff --git a/src/irmin-pack/unix/stats.mli b/src/irmin-pack/io/stats.mli similarity index 100% rename from src/irmin-pack/unix/stats.mli rename to src/irmin-pack/io/stats.mli diff --git a/src/irmin-pack/unix/stats_intf.ml b/src/irmin-pack/io/stats_intf.ml similarity index 100% rename from src/irmin-pack/unix/stats_intf.ml rename to src/irmin-pack/io/stats_intf.ml diff --git a/src/irmin-pack/unix/store.ml b/src/irmin-pack/io/store.ml similarity index 99% rename from src/irmin-pack/unix/store.ml rename to src/irmin-pack/io/store.ml index 14cd1eccd9..9993ef8b30 100644 --- a/src/irmin-pack/unix/store.ml +++ b/src/irmin-pack/io/store.ml @@ -17,7 +17,7 @@ open! Import include Store_intf -module Maker (Io : Io.S) (Io_index : Index.Platform.S) (Config : Conf.S) = +module Maker (Io : Io_intf.S) (Io_index : Index.Platform.S) (Config : Conf.S) = struct type endpoint = unit @@ -701,6 +701,7 @@ struct module Contents_pack = X.Contents.CA module Fm = File_manager module Dispatcher = Dispatcher + module Io_index = Io_index end) include S diff --git a/src/irmin-pack/unix/store.mli b/src/irmin-pack/io/store.mli similarity index 97% rename from src/irmin-pack/unix/store.mli rename to src/irmin-pack/io/store.mli index 7510aac381..0ad1298646 100644 --- a/src/irmin-pack/unix/store.mli +++ b/src/irmin-pack/io/store.mli @@ -18,6 +18,6 @@ include Store_intf.Sigs (** @inline *) module Maker - (Io : Io.S) + (Io : Io_intf.S) (Io_index : Index.Platform.S) (Config : Irmin_pack.Conf.S) : Maker diff --git a/src/irmin-pack/unix/store_intf.ml b/src/irmin-pack/io/store_intf.ml similarity index 99% rename from src/irmin-pack/unix/store_intf.ml rename to src/irmin-pack/io/store_intf.ml index e1bdd006b8..ceb1ec671c 100644 --- a/src/irmin-pack/unix/store_intf.ml +++ b/src/irmin-pack/io/store_intf.ml @@ -293,7 +293,7 @@ module type S = sig (** Unstable internal API agnostic about the underlying storage. Use it only to implement or test inodes. *) - module Io : Io.S + module Io : Io_intf.S module Errs : Io_errors.S with module Io = Io module Index : Pack_index.S with type key = hash diff --git a/src/irmin-pack/unix/traverse_pack_file.ml b/src/irmin-pack/io/traverse_pack_file.ml similarity index 99% rename from src/irmin-pack/unix/traverse_pack_file.ml rename to src/irmin-pack/io/traverse_pack_file.ml index 690c849cd1..ada3461d4c 100644 --- a/src/irmin-pack/unix/traverse_pack_file.ml +++ b/src/irmin-pack/io/traverse_pack_file.ml @@ -15,7 +15,6 @@ *) open! Import -module Io = Io.Unix module Stats : sig type t diff --git a/src/irmin-pack/unix/utils.ml b/src/irmin-pack/io/utils.ml similarity index 100% rename from src/irmin-pack/unix/utils.ml rename to src/irmin-pack/io/utils.ml diff --git a/src/irmin-pack/unix/dune b/src/irmin-pack/unix/dune index ebca669167..988c1e9b5d 100644 --- a/src/irmin-pack/unix/dune +++ b/src/irmin-pack/unix/dune @@ -6,7 +6,7 @@ index index.unix irmin - irmin-pack + irmin-pack.io logs eio mtime diff --git a/src/irmin-pack/unix/io.ml b/src/irmin-pack/unix/io.ml index fb9c92851a..c49d83b1d1 100644 --- a/src/irmin-pack/unix/io.ml +++ b/src/irmin-pack/unix/io.ml @@ -14,8 +14,8 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open! Import -open Io_intf +open! Irmin_pack_io.Import +module Errors = Irmin_pack_io.Errors module Syscalls = Index_unix.Syscalls (* File utils, taken from index.unix package. @@ -48,8 +48,6 @@ module Util = struct aux fd_offset 0 length end -module type S = S - module Unix = struct type misc_error = Unix.error * string * string diff --git a/src/irmin-pack/unix/io.mli b/src/irmin-pack/unix/io.mli index f6ec8493a2..332cbd9aaa 100644 --- a/src/irmin-pack/unix/io.mli +++ b/src/irmin-pack/unix/io.mli @@ -14,5 +14,4 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -include Io_intf.Sigs -(** @inline *) +module Unix : Irmin_pack_io.Io_s diff --git a/src/irmin-pack/unix/irmin_pack_unix.ml b/src/irmin-pack/unix/irmin_pack_unix.ml index 8b4309fd2b..ed4713a24b 100644 --- a/src/irmin-pack/unix/irmin_pack_unix.ml +++ b/src/irmin-pack/unix/irmin_pack_unix.ml @@ -16,25 +16,15 @@ (** {1 Store} *) -module type S = Store_intf.S -module type Io_s = Io.S - -module Maker_io = Store.Maker +module type S = Irmin_pack_io.Store_intf.S module Maker (Config : Irmin_pack.Conf.S) = - Store.Maker (Io.Unix) (Index_unix.Private.Platform) (Config) - -module KV (Config : Irmin_pack.Conf.S) = struct - type endpoint = unit - type hash = Irmin.Schema.default_hash + Irmin_pack_io.Maker_io (Io.Unix) (Index_unix.Private.Platform) (Config) - include Pack_key.Store_spec - module Maker = Maker (Config) +module KV (Config : Irmin_pack.Conf.S) = + Irmin_pack_io.KV (Io.Unix) (Index_unix.Private.Platform) (Config) - type metadata = Irmin.Metadata.None.t - - module Make (C : Irmin.Contents.S) = Maker.Make (Irmin.Schema.KV (C)) -end +open Irmin_pack_io (** {1 Key and Values} *) @@ -44,10 +34,20 @@ module Pack_value = Pack_value (** {1 Internal} *) module Stats = Stats -module Index = Pack_index + +module Index = struct + module type S = Index.S + + module Make (K : Irmin.Hash.S) = + Index.Make_io (Io.Unix) (Index_unix.Private.Platform) (K) +end + +module Checks = struct + module Make = Checks.Make (Io.Unix) (Index_unix.Private.Platform) +end + module Inode = Inode module Pack_store = Pack_store -module Checks = Checks module Atomic_write = Atomic_write module Dict = Dict module Dispatcher = Dispatcher diff --git a/src/irmin-pack/unix/irmin_pack_unix.mli b/src/irmin-pack/unix/irmin_pack_unix.mli index 589918d3ad..17ee437cc2 100644 --- a/src/irmin-pack/unix/irmin_pack_unix.mli +++ b/src/irmin-pack/unix/irmin_pack_unix.mli @@ -22,16 +22,12 @@ (** {1 Store} *) -module type S = Store.S -module type Io_s = Io.S +open Irmin_pack_io -module Maker_io - (Io : Io.S) - (Io_index : Index.Platform.S) - (Config : Irmin_pack.Conf.S) : Store.Maker +module type S = Irmin_pack_io.S -module Maker (Config : Irmin_pack.Conf.S) : Store.Maker -module KV (Config : Irmin_pack.Conf.S) : Store.KV +module Maker (Config : Irmin_pack.Conf.S) : Store_intf.Maker +module KV (Config : Irmin_pack.Conf.S) : Store_intf.KV (** {1 Key and Values} *) @@ -41,7 +37,9 @@ module Pack_value = Pack_value (** {1 Integrity Checks} *) -module Checks = Checks +module Checks : sig + module Make (_ : Checks_intf.Store) : Checks_intf.S +end (** {1 Statistics} *) @@ -52,7 +50,13 @@ module Stats = Stats (** Following functors and modules are instantiated automatically or used internally when creating a store with {!Maker} or {!KV}.*) -module Index = Pack_index +module Index : sig + module type S = Index.S + + module Make (K : Irmin.Hash.S) : + module type of Index.Make_io (Io.Unix) (Index_unix.Private.Platform) (K) +end + module Inode = Inode module Pack_store = Pack_store module Atomic_write = Atomic_write diff --git a/test/irmin-pack/test_pack.mli b/test/irmin-pack/test_pack.mli index 570b975109..03142f091b 100644 --- a/test/irmin-pack/test_pack.mli +++ b/test/irmin-pack/test_pack.mli @@ -15,4 +15,6 @@ *) val suite : Irmin_test.Suite.t list -val misc : Eio.Domain_manager.t -> (string * unit Alcotest.test_case list) list + +val misc : + _ Eio.Domain_manager.t -> (string * unit Alcotest.test_case list) list From b2f32d8647699f4bf95ff360141e74e23d92c07a Mon Sep 17 00:00:00 2001 From: ArthurW Date: Wed, 6 Sep 2023 17:02:26 +0200 Subject: [PATCH 75/99] irmin-pack: extract unix Async --- src/irmin-pack/io/async_intf.ml | 6 ------ src/irmin-pack/io/gc_args.ml | 2 +- src/irmin-pack/io/irmin_pack_io.ml | 5 +++-- src/irmin-pack/io/irmin_pack_io.mli | 4 +++- src/irmin-pack/io/store.ml | 8 ++++++-- src/irmin-pack/io/store.mli | 1 + src/irmin-pack/{io => unix}/async.ml | 15 +-------------- src/irmin-pack/{io => unix}/async.mli | 3 +-- src/irmin-pack/unix/irmin_pack_unix.ml | 5 +++-- 9 files changed, 19 insertions(+), 30 deletions(-) rename src/irmin-pack/{io => unix}/async.ml (92%) rename src/irmin-pack/{io => unix}/async.mli (95%) diff --git a/src/irmin-pack/io/async_intf.ml b/src/irmin-pack/io/async_intf.ml index 97edfc7b20..dad1c3c4fb 100644 --- a/src/irmin-pack/io/async_intf.ml +++ b/src/irmin-pack/io/async_intf.ml @@ -43,9 +43,3 @@ module type S = sig If not running, do nothing and return [false]. *) end - -module type Sigs = sig - module type S = S - - module Unix : S -end diff --git a/src/irmin-pack/io/gc_args.ml b/src/irmin-pack/io/gc_args.ml index 0880aa85a5..fe815d9f05 100644 --- a/src/irmin-pack/io/gc_args.ml +++ b/src/irmin-pack/io/gc_args.ml @@ -18,7 +18,7 @@ open! Import module type S = sig module Fm : File_manager.S - module Async : Async.S + module Async : Async_intf.S module Errs : Io_errors.S with module Io = Fm.Io module Dispatcher : Dispatcher.S with module Fm = Fm diff --git a/src/irmin-pack/io/irmin_pack_io.ml b/src/irmin-pack/io/irmin_pack_io.ml index 102a30fbf0..5d8f61788c 100644 --- a/src/irmin-pack/io/irmin_pack_io.ml +++ b/src/irmin-pack/io/irmin_pack_io.ml @@ -25,13 +25,14 @@ module Maker_io = Store.Maker module KV (Io : Io_intf.S) (Index_io : Index.Platform.S) + (Async : Async_intf.S) (Config : Irmin_pack.Conf.S) = struct type endpoint = unit type hash = Irmin.Schema.default_hash include Pack_key.Store_spec - module Maker = Store.Maker (Io) (Index_io) (Config) + module Maker = Store.Maker (Io) (Index_io) (Async) (Config) type metadata = Irmin.Metadata.None.t @@ -54,7 +55,7 @@ module Checks_intf = Checks_intf module Atomic_write = Atomic_write module Dict = Dict module Dispatcher = Dispatcher -module Async = Async +module Async_intf = Async_intf module Errors = Errors module Io_errors = Io_errors module Control_file = Control_file diff --git a/src/irmin-pack/io/irmin_pack_io.mli b/src/irmin-pack/io/irmin_pack_io.mli index 813ee59ed0..8a66f97b50 100644 --- a/src/irmin-pack/io/irmin_pack_io.mli +++ b/src/irmin-pack/io/irmin_pack_io.mli @@ -30,11 +30,13 @@ module Store_intf = Store_intf module Maker_io (Io : Io_intf.S) (Io_index : Index.Platform.S) + (Async : Async_intf.S) (Config : Irmin_pack.Conf.S) : Store.Maker module KV (Io : Io_intf.S) (Io_index : Index.Platform.S) + (Async : Async_intf.S) (Config : Irmin_pack.Conf.S) : Store.KV (** {1 Key and Values} *) @@ -62,7 +64,7 @@ module Pack_store = Pack_store module Atomic_write = Atomic_write module Dict = Dict module Dispatcher = Dispatcher -module Async = Async +module Async_intf = Async_intf module Errors = Errors module Io_errors = Io_errors module Control_file = Control_file diff --git a/src/irmin-pack/io/store.ml b/src/irmin-pack/io/store.ml index 9993ef8b30..740c6d184a 100644 --- a/src/irmin-pack/io/store.ml +++ b/src/irmin-pack/io/store.ml @@ -17,7 +17,11 @@ open! Import include Store_intf -module Maker (Io : Io_intf.S) (Io_index : Index.Platform.S) (Config : Conf.S) = +module Maker + (Io : Io_intf.S) + (Io_index : Index.Platform.S) + (Async : Async_intf.S) + (Config : Conf.S) = struct type endpoint = unit @@ -125,7 +129,7 @@ struct module Remote = Irmin.Backend.Remote.None (Commit.Key) (B) module Gc = Gc.Make (struct - module Async = Async.Unix + module Async = Async module Fm = File_manager module Errs = Errs module Dict = Dict diff --git a/src/irmin-pack/io/store.mli b/src/irmin-pack/io/store.mli index 0ad1298646..6281c12049 100644 --- a/src/irmin-pack/io/store.mli +++ b/src/irmin-pack/io/store.mli @@ -20,4 +20,5 @@ include Store_intf.Sigs module Maker (Io : Io_intf.S) (Io_index : Index.Platform.S) + (Async : Async_intf.S) (Config : Irmin_pack.Conf.S) : Maker diff --git a/src/irmin-pack/io/async.ml b/src/irmin-pack/unix/async.ml similarity index 92% rename from src/irmin-pack/io/async.ml rename to src/irmin-pack/unix/async.ml index a9a09a4b69..bf2caf81a9 100644 --- a/src/irmin-pack/io/async.ml +++ b/src/irmin-pack/unix/async.ml @@ -14,8 +14,7 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open! Import -include Async_intf +open! Irmin_pack_io.Import module Unix = struct let kill_no_err pid = @@ -58,17 +57,6 @@ module Unix = struct end let async f = - let exit_code = - match f () with - | () -> Exit_code.success - | exception e -> - [%log.err - "Unhandled exception in child process %s" (Printexc.to_string e)]; - Exit_code.unhandled_exn - in - { pid = -1; status = `Success; lock = Eio.Mutex.create () } - - (* Stdlib.flush_all (); match Unix.fork () with | 0 -> @@ -87,7 +75,6 @@ module Unix = struct | pid -> Exit.add pid; { pid; status = `Running; lock = Eio.Mutex.create () } - *) let status_of_process_outcome = function | Unix.WEXITED n when n = Exit_code.success -> `Success diff --git a/src/irmin-pack/io/async.mli b/src/irmin-pack/unix/async.mli similarity index 95% rename from src/irmin-pack/io/async.mli rename to src/irmin-pack/unix/async.mli index ab3aa6f098..796ae52765 100644 --- a/src/irmin-pack/io/async.mli +++ b/src/irmin-pack/unix/async.mli @@ -14,5 +14,4 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -include Async_intf.Sigs -(** @inline *) +module Unix : Irmin_pack_io.Async_intf.S diff --git a/src/irmin-pack/unix/irmin_pack_unix.ml b/src/irmin-pack/unix/irmin_pack_unix.ml index ed4713a24b..60b93a5e92 100644 --- a/src/irmin-pack/unix/irmin_pack_unix.ml +++ b/src/irmin-pack/unix/irmin_pack_unix.ml @@ -19,10 +19,11 @@ module type S = Irmin_pack_io.Store_intf.S module Maker (Config : Irmin_pack.Conf.S) = - Irmin_pack_io.Maker_io (Io.Unix) (Index_unix.Private.Platform) (Config) + Irmin_pack_io.Maker_io (Io.Unix) (Index_unix.Private.Platform) (Async.Unix) + (Config) module KV (Config : Irmin_pack.Conf.S) = - Irmin_pack_io.KV (Io.Unix) (Index_unix.Private.Platform) (Config) + Irmin_pack_io.KV (Io.Unix) (Index_unix.Private.Platform) (Async.Unix) (Config) open Irmin_pack_io From a664ac8c9e05b3233367d000f2d0f4f608bc018e Mon Sep 17 00:00:00 2001 From: ArthurW Date: Wed, 6 Sep 2023 19:02:12 +0200 Subject: [PATCH 76/99] irmin-pack: extract remaining Unix functions --- src/irmin-pack/io/checks.ml | 11 +---- src/irmin-pack/io/file_manager.ml | 7 +-- src/irmin-pack/io/gc.ml | 17 ++++--- src/irmin-pack/io/gc_stats.ml | 65 +++++++------------------ src/irmin-pack/io/gc_stats.mli | 4 +- src/irmin-pack/io/gc_worker.ml | 33 +++++++------ src/irmin-pack/io/io_intf.ml | 14 ++++-- src/irmin-pack/io/irmin_pack_io.ml | 1 + src/irmin-pack/io/irmin_pack_io.mli | 1 + src/irmin-pack/io/lower.ml | 2 +- src/irmin-pack/io/snapshot.ml | 18 ++++--- src/irmin-pack/io/store.ml | 4 +- src/irmin-pack/io/traverse_pack_file.ml | 5 +- src/irmin-pack/unix/io.ml | 30 ++++++++++++ 14 files changed, 106 insertions(+), 106 deletions(-) diff --git a/src/irmin-pack/io/checks.ml b/src/irmin-pack/io/checks.ml index 1f1a96bdc3..a1bf29e64a 100644 --- a/src/irmin-pack/io/checks.ml +++ b/src/irmin-pack/io/checks.ml @@ -50,16 +50,9 @@ let path = let deprecated_info = (Cmdliner.Term.info [@alert "-deprecated"]) -let ppf_or_null ppf = - let null = - match Sys.os_type with - | "Unix" | "Cygwin" -> "/dev/null" - | "Win32" -> "NUL" - | _ -> invalid_arg "invalid os type" - in - match ppf with +let ppf_or_null = function | Some p -> p - | None -> open_out null |> Format.formatter_of_out_channel + | None -> Format.make_formatter (fun _ _ _ -> ()) (fun () -> ()) module Make (Io : Io_intf.S) (Io_index : Index.Platform.S) (Store : Store) = struct diff --git a/src/irmin-pack/io/file_manager.ml b/src/irmin-pack/io/file_manager.ml index 1386e1ef66..3f39e40959 100644 --- a/src/irmin-pack/io/file_manager.ml +++ b/src/irmin-pack/io/file_manager.ml @@ -258,12 +258,8 @@ struct | None -> Ok () let cleanup ~root ~generation ~chunk_start_idx ~chunk_num ~lower = - ignore (root, generation, chunk_start_idx, chunk_num, lower); - Ok () - (* let () = - Sys.readdir root - |> Array.to_list + Io.readdir root |> List.filter (fun filename -> match Irmin_pack.Layout.Classification.Upper.v filename with | `Unknown | `Branch | `Control | `Dict | `V1_or_v2_pack -> false @@ -281,7 +277,6 @@ struct "Could not remove residual file %s: %s" filename error]) in Option.might (Lower.cleanup ~generation) lower - *) let add_volume_and_update_control lower control = let open Result_syntax in diff --git a/src/irmin-pack/io/gc.ml b/src/irmin-pack/io/gc.ml index afda2baf40..b633f1e7dd 100644 --- a/src/irmin-pack/io/gc.ml +++ b/src/irmin-pack/io/gc.ml @@ -23,6 +23,7 @@ module Make (Args : Gc_args.S) = struct module Io = Fm.Io module Ao = Append_only_file.Make (Io) (Errs) module Worker = Gc_worker.Make (Args) + module Gc_stats_main = Gc_stats.Main (Io) type t = { root : string; @@ -37,7 +38,7 @@ module Make (Args : Gc_args.S) = struct contents : read Contents_store.t; node : read Node_store.t; commit : read Commit_store.t; - mutable partial_stats : Gc_stats.Main.t; + mutable partial_stats : Gc_stats_main.t; mutable resulting_stats : Stats.Latest_gc.stats option; latest_gc_target_offset : int63; } @@ -88,7 +89,7 @@ module Make (Args : Gc_args.S) = struct Dispatcher.suffix_start_offset dispatcher in let before_suffix_end_offset = Dispatcher.end_offset dispatcher in - Gc_stats.Main.create "worker startup" ~commit_offset ~generation + Gc_stats_main.create "worker startup" ~commit_offset ~generation ~before_suffix_start_offset ~before_suffix_end_offset ~after_suffix_start_offset:new_suffix_start_offset in @@ -117,7 +118,7 @@ module Make (Args : Gc_args.S) = struct ~lower_root ~generation ~new_files_path) in let partial_stats = - Gc_stats.Main.finish_current_step partial_stats "before finalise" + Gc_stats_main.finish_current_step partial_stats "before finalise" in Ok { @@ -250,11 +251,11 @@ module Make (Args : Gc_args.S) = struct | None -> ( let partial_stats = t.partial_stats in let partial_stats = - Gc_stats.Main.finish_current_step partial_stats "worker wait" + Gc_stats_main.finish_current_step partial_stats "worker wait" in let go status = let partial_stats = - Gc_stats.Main.finish_current_step partial_stats "read output" + Gc_stats_main.finish_current_step partial_stats "read output" in let gc_output = @@ -266,12 +267,12 @@ module Make (Args : Gc_args.S) = struct match (status, gc_output) with | `Success, Ok gc_results -> let partial_stats = - Gc_stats.Main.finish_current_step partial_stats + Gc_stats_main.finish_current_step partial_stats "swap and purge" in let* () = swap_and_purge t gc_results in let partial_stats = - Gc_stats.Main.finish_current_step partial_stats "unlink" + Gc_stats_main.finish_current_step partial_stats "unlink" in if t.unlink then unlink_all t gc_results.removable_chunk_idxs; @@ -279,7 +280,7 @@ module Make (Args : Gc_args.S) = struct let after_suffix_end_offset = Dispatcher.end_offset t.dispatcher in - Gc_stats.Main.finalise partial_stats gc_results.stats + Gc_stats_main.finalise partial_stats gc_results.stats ~after_suffix_end_offset in Stats.report_latest_gc stats; diff --git a/src/irmin-pack/io/gc_stats.ml b/src/irmin-pack/io/gc_stats.ml index f2bbbd81c9..a66d7a3849 100644 --- a/src/irmin-pack/io/gc_stats.ml +++ b/src/irmin-pack/io/gc_stats.ml @@ -16,7 +16,7 @@ open! Import -module Steps_timer = struct +module Steps_timer (Io : Io_intf.S) = struct type duration = Stats.Latest_gc.duration = { wall : float; sys : float; @@ -25,23 +25,17 @@ module Steps_timer = struct type t = { timer : duration; prev_stepname : string } - let get_wtime () = - (Mtime_clock.now () |> Mtime.to_uint64_ns |> Int64.to_float) /. 1e9 - - let get_stime () = Rusage.((get Self).stime) - let get_utime () = Rusage.((get Self).utime) - let create first_stepname = - let wall = get_wtime () in - let sys = get_stime () in - let user = get_utime () in + let wall = Io.Stats.get_wtime () in + let sys = Io.Stats.get_stime () in + let user = Io.Stats.get_utime () in let timer = { wall; sys; user } in { timer; prev_stepname = first_stepname } let progress prev next_stepname = - let wall = get_wtime () in - let sys = get_stime () in - let user = get_utime () in + let wall = Io.Stats.get_wtime () in + let sys = Io.Stats.get_stime () in + let user = Io.Stats.get_utime () in let next = { wall; sys; user } in let wall = next.wall -. prev.timer.wall in @@ -53,8 +47,9 @@ module Steps_timer = struct (next, delta) end -module Main = struct +module Main (Io : Io_intf.S) = struct module S = Stats.Latest_gc + module Steps_timer = Steps_timer (Io) type t = { stats : S.stats; timer : Steps_timer.t } (** [t] is the running state while computing the stats *) @@ -96,7 +91,7 @@ module Main = struct } end -module Worker = struct +module Worker (Io : Io_intf.S) = struct module S = Stats.Latest_gc type t = { @@ -110,30 +105,6 @@ module Worker = struct } (** [t] is the running state while computing the stats *) - let is_darwin = - lazy - (try - match Unix.open_process_in "uname" |> input_line with - | "Darwin" -> true - | _ -> false - with Unix.Unix_error _ -> false) - - let get_wtime () = - (Mtime_clock.now () |> Mtime.to_uint64_ns |> Int64.to_float) /. 1e9 - - let get_stime () = Rusage.((get Self).stime) - let get_utime () = Rusage.((get Self).utime) - - let get_rusage : unit -> S.rusage = - fun () -> - let Rusage.{ maxrss; minflt; majflt; inblock; oublock; nvcsw; nivcsw; _ } = - Rusage.(get Self) - in - let maxrss = - if Lazy.force is_darwin then Int64.div maxrss 1000L else maxrss - in - S.{ maxrss; minflt; majflt; inblock; oublock; nvcsw; nivcsw } - let get_ocaml_gc : unit -> S.ocaml_gc = fun () -> let open Stdlib.Gc in @@ -160,10 +131,10 @@ module Worker = struct Stats.reset_stats (); Irmin_pack.Stats.reset_stats (); - let wtime = get_wtime () in - let stime = get_stime () in - let utime = get_utime () in - let rusage = get_rusage () in + let wtime = Io.Stats.get_wtime () in + let stime = Io.Stats.get_stime () in + let utime = Io.Stats.get_utime () in + let rusage = Io.Stats.get_rusage () in let ocaml_gc = get_ocaml_gc () in let stats = @@ -200,9 +171,9 @@ module Worker = struct { t with stats } let finish_current_step t next_stepname = - let wtime = get_wtime () in - let stime = get_stime () in - let utime = get_utime () in + let wtime = Io.Stats.get_wtime () in + let stime = Io.Stats.get_stime () in + let utime = Io.Stats.get_utime () in let duration = let wall = wtime -. t.prev_wtime in let sys = stime -. t.prev_stime in @@ -212,7 +183,7 @@ module Worker = struct let prev_rusage, rusage = let x = t.prev_rusage in - let y = get_rusage () in + let y = Io.Stats.get_rusage () in let ( - ) = Int64.sub in ( y, S. diff --git a/src/irmin-pack/io/gc_stats.mli b/src/irmin-pack/io/gc_stats.mli index 96680dfc63..089e329b94 100644 --- a/src/irmin-pack/io/gc_stats.mli +++ b/src/irmin-pack/io/gc_stats.mli @@ -18,7 +18,7 @@ open! Import (** Stat collection during GC *) -module Main : sig +module Main (Io : Io_intf.S) : sig type t val create : @@ -39,7 +39,7 @@ module Main : sig Stats.Latest_gc.stats end -module Worker : sig +module Worker (Io : Io_intf.S) : sig type t val create : string -> t diff --git a/src/irmin-pack/io/gc_worker.ml b/src/irmin-pack/io/gc_worker.ml index bfc01b2cd7..96bc04ce71 100644 --- a/src/irmin-pack/io/gc_worker.ml +++ b/src/irmin-pack/io/gc_worker.ml @@ -26,6 +26,7 @@ module Make (Args : Gc_args.S) = struct module Dict = Fm.Dict module Sparse = Fm.Sparse module Ao = Append_only_file.Make (Fm.Io) (Errs) + module Gc_stats_worker = Gc_stats.Worker (Io) let string_of_key = Irmin.Type.to_string key_t @@ -183,14 +184,14 @@ module Make (Args : Gc_args.S) = struct let report_old_file_sizes ~root ~generation stats = let open Result_syntax in let+ mapping_size, prefix_size = prefix_file_sizes ~root ~generation in - stats := Gc_stats.Worker.add_file_size !stats "old_prefix" prefix_size; - stats := Gc_stats.Worker.add_file_size !stats "old_mapping" mapping_size + stats := Gc_stats_worker.add_file_size !stats "old_prefix" prefix_size; + stats := Gc_stats_worker.add_file_size !stats "old_mapping" mapping_size let report_new_file_sizes ~root ~generation stats = let open Result_syntax in let+ mapping_size, prefix_size = prefix_file_sizes ~root ~generation in - stats := Gc_stats.Worker.add_file_size !stats "prefix" prefix_size; - stats := Gc_stats.Worker.add_file_size !stats "mapping" mapping_size + stats := Gc_stats_worker.add_file_size !stats "prefix" prefix_size; + stats := Gc_stats_worker.add_file_size !stats "mapping" mapping_size type suffix_params = { start_offset : int63; @@ -220,7 +221,7 @@ module Make (Args : Gc_args.S) = struct (* Step 1. Open the files *) [%log.debug "GC: opening files in RO mode"]; - let stats = ref (Gc_stats.Worker.create "open files") in + let stats = ref (Gc_stats_worker.create "open files") in let () = report_old_file_sizes ~root ~generation:(generation - 1) stats |> ignore in @@ -237,7 +238,7 @@ module Make (Args : Gc_args.S) = struct (* Step 2. Load commit which will make [commit_key] [Direct] if it's not already the case. *) - stats := Gc_stats.Worker.finish_current_step !stats "load commit"; + stats := Gc_stats_worker.finish_current_step !stats "load commit"; let commit = match Commit_store.unsafe_find ~check_integrity:false commit_store commit_key @@ -250,18 +251,18 @@ module Make (Args : Gc_args.S) = struct (* Step 3. Compute the list of [offset, length] ranges of live objects reachable from the GC commit. *) let live_entries = - stats := Gc_stats.Worker.finish_current_step !stats "mapping: start"; + stats := Gc_stats_worker.finish_current_step !stats "mapping: start"; let live_entries = snapshot_commit commit_key commit_store node_store in stats := - Gc_stats.Worker.finish_current_step !stats "mapping: of reachable"; + Gc_stats_worker.finish_current_step !stats "mapping: of reachable"; stats := - Gc_stats.Worker.set_objects_traversed !stats (Ranges.count live_entries); + Gc_stats_worker.set_objects_traversed !stats (Ranges.count live_entries); live_entries in let mapping_size = (* Step 4. Create the new prefix. *) - stats := Gc_stats.Worker.finish_current_step !stats "prefix: start"; + stats := Gc_stats_worker.finish_current_step !stats "prefix: start"; let mapping = Irmin_pack.Layout.V4.mapping ~root:new_files_path ~generation in @@ -270,7 +271,7 @@ module Make (Args : Gc_args.S) = struct let prefix = Sparse.Ao.create ~mapping ~data |> Errs.raise_if_error in (* Step 5. Transfer to the new prefix, flush and close. *) [%log.debug "GC: transfering to the new prefix"]; - stats := Gc_stats.Worker.finish_current_step !stats "prefix: transfer"; + stats := Gc_stats_worker.finish_current_step !stats "prefix: transfer"; Errors.finalise_exn (fun _ -> Sparse.Ao.flush prefix >>= (fun _ -> Sparse.Ao.close prefix) @@ -289,7 +290,7 @@ module Make (Args : Gc_args.S) = struct prefix, this time in write-only as we have to modify data inside the file. *) stats := - Gc_stats.Worker.finish_current_step !stats + Gc_stats_worker.finish_current_step !stats "prefix: rewrite commit parents"; let prefix = Sparse.Wo.open_wo ~mapping_size ~mapping ~data |> Errs.raise_if_error @@ -311,7 +312,7 @@ module Make (Args : Gc_args.S) = struct (* Step 6. Calculate post-GC suffix parameters. *) let suffix_params, mapping_size, removable_chunk_idxs = stats := - Gc_stats.Worker.finish_current_step !stats + Gc_stats_worker.finish_current_step !stats "suffix: calculate new values"; let suffix = Fm.suffix fm in let soff = Dispatcher.soff_of_offset dispatcher new_suffix_start_offset in @@ -382,7 +383,7 @@ module Make (Args : Gc_args.S) = struct | `Archive lower -> [%log.debug "GC: archiving into lower"]; stats := - Gc_stats.Worker.finish_current_step !stats "archive: iter reachable"; + Gc_stats_worker.finish_current_step !stats "archive: iter reachable"; let min_offset = Dispatcher.suffix_start_offset dispatcher in let to_archive = ref [] in Ranges.iter @@ -393,7 +394,7 @@ module Make (Args : Gc_args.S) = struct (traverse_range ~min_offset commit_key commit_store node_store); let to_archive = List.rev !to_archive in stats := - Gc_stats.Worker.finish_current_step !stats "archive: copy to lower"; + Gc_stats_worker.finish_current_step !stats "archive: copy to lower"; Lower.set_readonly lower false; let vol = Lower.archive_seq_exn ~upper_root:root ~generation ~to_archive lower @@ -403,7 +404,7 @@ module Make (Args : Gc_args.S) = struct in (* Step 8. Finalise stats and return. *) - let stats = Gc_stats.Worker.finalise !stats in + let stats = Gc_stats_worker.finalise !stats in { suffix_params; mapping_size; diff --git a/src/irmin-pack/io/io_intf.ml b/src/irmin-pack/io/io_intf.ml index 4d3b42bcbc..27d55cc1ad 100644 --- a/src/irmin-pack/io/io_intf.ml +++ b/src/irmin-pack/io/io_intf.ml @@ -84,6 +84,7 @@ module type S = sig src:string -> dst:string -> (unit, [> `Sys_error of string ]) result val mkdir : string -> (unit, [> mkdir_error ]) result + val rmdir : string -> unit val unlink : string -> (unit, [> `Sys_error of string ]) result val unlink_dont_wait : on_exn:(exn -> unit) -> string -> unit @@ -121,6 +122,8 @@ module type S = sig val classify_path : string -> [> `File | `Directory | `No_such_file_or_directory | `Other ] + val readdir : string -> string list + (** {1 MISC.} *) val readonly : t -> bool @@ -153,10 +156,11 @@ module type S = sig val catch_misc_error : (unit -> 'a) -> ('a, [> `Io_misc of misc_error ]) result -end - -module type Sigs = sig - module type S = S - module Unix : S with type misc_error = Unix.error * string * string + module Stats : sig + val get_rusage : unit -> Stats.Latest_gc.rusage + val get_wtime : unit -> float + val get_stime : unit -> float + val get_utime : unit -> float + end end diff --git a/src/irmin-pack/io/irmin_pack_io.ml b/src/irmin-pack/io/irmin_pack_io.ml index 5d8f61788c..97532b95b2 100644 --- a/src/irmin-pack/io/irmin_pack_io.ml +++ b/src/irmin-pack/io/irmin_pack_io.ml @@ -47,6 +47,7 @@ module Pack_value = Pack_value (** {1 Internal} *) module Stats = Stats +module Stats_intf = Stats_intf module Index = Pack_index module Inode = Inode module Pack_store = Pack_store diff --git a/src/irmin-pack/io/irmin_pack_io.mli b/src/irmin-pack/io/irmin_pack_io.mli index 8a66f97b50..0c20e3a3fb 100644 --- a/src/irmin-pack/io/irmin_pack_io.mli +++ b/src/irmin-pack/io/irmin_pack_io.mli @@ -52,6 +52,7 @@ module Checks_intf = Checks_intf (** {1 Statistics} *) module Stats = Stats +module Stats_intf = Stats_intf (** {1 Internal Functors and Utilities} *) diff --git a/src/irmin-pack/io/lower.ml b/src/irmin-pack/io/lower.ml index 5b884bce82..6799a11267 100644 --- a/src/irmin-pack/io/lower.ml +++ b/src/irmin-pack/io/lower.ml @@ -250,7 +250,7 @@ struct |> Result.ok | _ -> Ok () in - path t |> Sys.readdir |> Array.to_list |> List.iter_result clean + path t |> Io.readdir |> List.iter_result clean end module Make (Io : Io_intf.S) (Errs : Io_errors.S with module Io = Io) = struct diff --git a/src/irmin-pack/io/snapshot.ml b/src/irmin-pack/io/snapshot.ml index 87cfe4675b..fdfccf3c67 100644 --- a/src/irmin-pack/io/snapshot.ml +++ b/src/irmin-pack/io/snapshot.ml @@ -17,18 +17,22 @@ open! Import open Snapshot_intf -let rm_index path = - let path_index = Filename.concat path "index" in - Sys.readdir path_index - |> Array.iter (fun name -> Unix.unlink (Filename.concat path_index name)); - Unix.rmdir path_index; - Unix.rmdir path - module Make (Args : Args) = struct module Hashes = Irmin.Hash.Set.Make (Args.Hash) open Args module Inode_pack = Inode.Pack module Pack_index = Fm.Index + module Io = Fm.Io + + let rm_index path = + let path_index = Filename.concat path "index" in + Io.readdir path_index + |> List.iter (fun name -> + match Io.unlink (Filename.concat path_index name) with + | Ok () -> () + | Error (`Sys_error msg) -> failwith msg); + Io.rmdir path_index; + Io.rmdir path let pp_hash = Irmin.Type.pp Hash.t let pp_key = Irmin.Type.pp Inode_pack.Key.t diff --git a/src/irmin-pack/io/store.ml b/src/irmin-pack/io/store.ml index 740c6d184a..0a002c025a 100644 --- a/src/irmin-pack/io/store.ml +++ b/src/irmin-pack/io/store.ml @@ -790,9 +790,7 @@ struct let kill_gc (repo : X.Repo.t) = match (Atomic.get repo.running_gc : X.Repo.running_gc option) with | None -> false - | Some { gc; _ } -> ( - try X.Gc.cancel gc - with Unix.Unix_error (Unix.ESRCH, "kill", _) -> false) + | Some { gc; _ } -> X.Gc.cancel gc end end end diff --git a/src/irmin-pack/io/traverse_pack_file.ml b/src/irmin-pack/io/traverse_pack_file.ml index ada3461d4c..eb3592426e 100644 --- a/src/irmin-pack/io/traverse_pack_file.ml +++ b/src/irmin-pack/io/traverse_pack_file.ml @@ -84,7 +84,8 @@ module Make (Args : Args) : sig unit end = struct open Args - module Errs = Io_errors.Make (File_manager.Io) + module Io = File_manager.Io + module Errs = Io_errors.Make (Io) let pp_key = Irmin.Type.pp Hash.t let decode_key = Irmin.Type.(unstage (decode_bin Hash.t)) @@ -117,7 +118,7 @@ end = struct let dest = match dest with | `Output path -> - if Sys.file_exists path then + if Io.classify_path path <> `No_such_file_or_directory then Fmt.invalid_arg "Can't reconstruct index. File already exits."; path | `In_place -> diff --git a/src/irmin-pack/unix/io.ml b/src/irmin-pack/unix/io.ml index c49d83b1d1..4443f6270d 100644 --- a/src/irmin-pack/unix/io.ml +++ b/src/irmin-pack/unix/io.ml @@ -100,6 +100,7 @@ module Unix = struct | _ -> `Other with _ -> `No_such_file_or_directory) + let readdir p = Sys.readdir p |> Array.to_list let default_create_perm = 0o644 let default_open_perm = 0o644 let default_mkdir_perm = 0o755 @@ -288,6 +289,8 @@ module Unix = struct Error (`No_such_file_or_directory path) | _ -> Error `Invalid_parent_directory + let rmdir path = Sys.rmdir path + let unlink path = try Sys.remove path; @@ -297,4 +300,31 @@ module Unix = struct let unlink_dont_wait ~on_exn path = (* TODO: Lwt.dont_wait (fun () -> Lwt_unix.unlink path) on_exn *) try Sys.remove path with err -> on_exn err + + module Stats = struct + let is_darwin = + lazy + (try + match Unix.open_process_in "uname" |> input_line with + | "Darwin" -> true + | _ -> false + with Unix.Unix_error _ -> false) + + let get_wtime () = + (Mtime_clock.now () |> Mtime.to_uint64_ns |> Int64.to_float) /. 1e9 + + let get_stime () = Rusage.((get Self).stime) + let get_utime () = Rusage.((get Self).utime) + + let get_rusage () = + let Rusage.{ maxrss; minflt; majflt; inblock; oublock; nvcsw; nivcsw; _ } + = + Rusage.(get Self) + in + let maxrss = + if Lazy.force is_darwin then Int64.div maxrss 1000L else maxrss + in + Irmin_pack_io.Stats_intf.Latest_gc. + { maxrss; minflt; majflt; inblock; oublock; nvcsw; nivcsw } + end end From 161310bcc96183dec73570951d1c6e157b8b8346 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Wed, 6 Sep 2023 20:20:16 +0200 Subject: [PATCH 77/99] irmin-pack: fix Gc.on_finalise --- bench/irmin-pack/tree.ml | 153 +++++++++++++++++---------------- src/irmin-pack/io/gc.ml | 22 ++--- src/irmin-pack/io/gc_worker.ml | 12 +-- 3 files changed, 86 insertions(+), 101 deletions(-) diff --git a/bench/irmin-pack/tree.ml b/bench/irmin-pack/tree.ml index e087cc6b6e..a3fbfa6bd8 100644 --- a/bench/irmin-pack/tree.ml +++ b/bench/irmin-pack/tree.ml @@ -302,82 +302,83 @@ type suite_elt = { } let suite : suite_elt list = - [ - { - mode = `Read_trace; - speed = `Quick; - run = - (fun config -> - let config = - { config with inode_config = (32, 256); store_type = `Pack } - in - let (module Store) = store_of_config config in - Store.run_read_trace config); - }; - { - mode = `Read_trace; - speed = `Slow; - run = - (fun config -> - let config = - { config with inode_config = (32, 256); store_type = `Pack } - in - let (module Store) = store_of_config config in - Store.run_read_trace config); - }; - { - mode = `Chains; - speed = `Quick; - run = - (fun config -> - let config = - { config with inode_config = (32, 256); store_type = `Pack } - in - let (module Store) = store_of_config config in - Store.run_chains config); - }; - { - mode = `Chains; - speed = `Slow; - run = - (fun config -> - let config = - { config with inode_config = (2, 5); store_type = `Pack } - in - let (module Store) = store_of_config config in - Store.run_chains config); - }; - { - mode = `Large; - speed = `Quick; - run = - (fun config -> - let config = - { config with inode_config = (32, 256); store_type = `Pack } - in - let (module Store) = store_of_config config in - Store.run_large config); - }; - { - mode = `Large; - speed = `Slow; - run = - (fun config -> - let config = - { config with inode_config = (2, 5); store_type = `Pack } - in - let (module Store) = store_of_config config in - Store.run_large config); - }; - { - mode = `Read_trace; - speed = `Custom; - run = - (fun config -> - let (module Store) = store_of_config config in - Store.run_read_trace config); - }; - ] + List.rev + [ + { + mode = `Read_trace; + speed = `Quick; + run = + (fun config -> + let config = + { config with inode_config = (32, 256); store_type = `Pack } + in + let (module Store) = store_of_config config in + Store.run_read_trace config); + }; + { + mode = `Read_trace; + speed = `Slow; + run = + (fun config -> + let config = + { config with inode_config = (32, 256); store_type = `Pack } + in + let (module Store) = store_of_config config in + Store.run_read_trace config); + }; + { + mode = `Chains; + speed = `Quick; + run = + (fun config -> + let config = + { config with inode_config = (32, 256); store_type = `Pack } + in + let (module Store) = store_of_config config in + Store.run_chains config); + }; + { + mode = `Chains; + speed = `Slow; + run = + (fun config -> + let config = + { config with inode_config = (2, 5); store_type = `Pack } + in + let (module Store) = store_of_config config in + Store.run_chains config); + }; + { + mode = `Large; + speed = `Quick; + run = + (fun config -> + let config = + { config with inode_config = (32, 256); store_type = `Pack } + in + let (module Store) = store_of_config config in + Store.run_large config); + }; + { + mode = `Large; + speed = `Slow; + run = + (fun config -> + let config = + { config with inode_config = (2, 5); store_type = `Pack } + in + let (module Store) = store_of_config config in + Store.run_large config); + }; + { + mode = `Read_trace; + speed = `Custom; + run = + (fun config -> + let (module Store) = store_of_config config in + Store.run_read_trace config); + }; + ] let get_suite suite_filter = List.filter diff --git a/src/irmin-pack/io/gc.ml b/src/irmin-pack/io/gc.ml index b633f1e7dd..e9cd0bda0f 100644 --- a/src/irmin-pack/io/gc.ml +++ b/src/irmin-pack/io/gc.ml @@ -31,8 +31,7 @@ module Make (Args : Gc_args.S) = struct task : Async.t; unlink : bool; new_suffix_start_offset : int63; - resolver : (Stats.Latest_gc.stats, Errs.t) result Eio.Promise.u; - promise : (Stats.Latest_gc.stats, Errs.t) result Eio.Promise.t; + mutable on_finalise : (Stats.Latest_gc.stats, Args.Errs.t) result -> unit; dispatcher : Dispatcher.t; fm : Fm.t; contents : read Contents_store.t; @@ -109,8 +108,6 @@ module Make (Args : Gc_args.S) = struct (* Unlink next gc's result file, in case it is on disk, for instance after a failed gc. *) unlink_result_file (); - (* internal promise for gc *) - let promise, resolver = Eio.Promise.create () in (* start worker task *) let task = Async.async (fun () -> @@ -127,8 +124,7 @@ module Make (Args : Gc_args.S) = struct unlink; new_suffix_start_offset; task; - promise; - resolver; + on_finalise = (fun _ -> ()); dispatcher; fm; contents; @@ -290,12 +286,12 @@ module Make (Args : Gc_args.S) = struct "Gc ended successfully. %a" (Irmin.Type.pp Stats.Latest_gc.stats_t) stats]; - let () = Eio.Promise.resolve_ok t.resolver stats in + let () = t.on_finalise (Ok stats) in Ok (`Finalised stats) | _ -> clean_after_abort t; let err = gc_errors status gc_output in - let () = Eio.Promise.resolve t.resolver err in + let () = t.on_finalise err in err in result @@ -324,14 +320,8 @@ module Make (Args : Gc_args.S) = struct | _ -> gc_errors status gc_output |> Errs.raise_if_error let on_finalise t f = - (* Ignore returned promise since the purpose of this - function is to add asynchronous callbacks to the GC - process -- this promise binding is an internal - implementation detail. This is safe since the callback - [f] is attached to [t.running_gc.promise], which is - referenced for the lifetime of a GC process. *) - let _ = f (Eio.Promise.await t.promise) in - () + (* TODO: finaliser should be defined on GC creation, not set later *) + t.on_finalise <- f let cancel t = let cancelled = Async.cancel t.task in diff --git a/src/irmin-pack/io/gc_worker.ml b/src/irmin-pack/io/gc_worker.ml index 96bc04ce71..3ffb748c79 100644 --- a/src/irmin-pack/io/gc_worker.ml +++ b/src/irmin-pack/io/gc_worker.ml @@ -427,18 +427,12 @@ module Make (Args : Gc_args.S) = struct let run_and_output_result ~lower_root ~generation ~new_files_path root commit_key new_suffix_start_offset = let result = - try - Errs.catch (fun () -> - run ~lower_root ~generation ~new_files_path root commit_key - new_suffix_start_offset) - with e -> - Format.printf "GC ERROR: %s@." (Printexc.to_string e); - Printexc.print_backtrace stdout; - raise e + Errs.catch (fun () -> + run ~lower_root ~generation ~new_files_path root commit_key + new_suffix_start_offset) in Errs.log_if_error "gc run" result; let write_result = write_gc_output ~root ~generation result in - Format.printf "GC WORKER is done!@."; write_result |> Errs.log_if_error "writing gc output" (* No need to raise or log if [result] is [Error _], we've written it in the file. *) From e42fb190b4faa54be2506faf7475b57d3a7992a7 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Fri, 8 Sep 2023 18:42:15 +0200 Subject: [PATCH 78/99] mirage: irmin-pack.unix is optional --- src/irmin-pack/unix/dune | 1 + 1 file changed, 1 insertion(+) diff --git a/src/irmin-pack/unix/dune b/src/irmin-pack/unix/dune index 988c1e9b5d..3e8bb6c693 100644 --- a/src/irmin-pack/unix/dune +++ b/src/irmin-pack/unix/dune @@ -1,6 +1,7 @@ (library (public_name irmin-pack.unix) (name irmin_pack_unix) + (optional) (libraries fmt index From 26a1497c31a68392df92e3b9c92882082ac910b9 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Fri, 8 Sep 2023 21:57:56 +0200 Subject: [PATCH 79/99] irmin-pack.io: remove rusage dependency --- src/irmin-pack/io/dune | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/irmin-pack/io/dune b/src/irmin-pack/io/dune index ae24701c34..cf1bc75095 100644 --- a/src/irmin-pack/io/dune +++ b/src/irmin-pack/io/dune @@ -12,8 +12,7 @@ cmdliner optint checkseum - checkseum.ocaml - rusage) + checkseum.ocaml) (preprocess (pps ppx_irmin.internal)) (instrumentation From 6e17751684be294cfb56e5c7bf68e94c2b003cfe Mon Sep 17 00:00:00 2001 From: ArthurW Date: Fri, 8 Sep 2023 22:54:27 +0200 Subject: [PATCH 80/99] mirage: remove dependency to fmt_tty --- src/irmin-pack/io/checks.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/src/irmin-pack/io/checks.ml b/src/irmin-pack/io/checks.ml index a1bf29e64a..02aceb80a2 100644 --- a/src/irmin-pack/io/checks.ml +++ b/src/irmin-pack/io/checks.ml @@ -36,7 +36,6 @@ let setup_log = in { Logs.report } in - Fmt_tty.setup_std_outputs ?style_renderer (); Logs.set_level level; Logs.set_reporter format_reporter in From ce0b76f7ecfac57169c864671566adb1bc3b44c1 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Mon, 11 Sep 2023 14:21:05 +0200 Subject: [PATCH 81/99] mirage: remove dependency to mtime.clock.os --- src/irmin-pack/io/file_manager.ml | 6 +++--- src/irmin-pack/io/io_intf.ml | 7 +++++++ src/irmin-pack/io/store.ml | 4 ++-- src/irmin-pack/io/traverse_pack_file.ml | 4 ++-- src/irmin-pack/unix/dune | 1 + src/irmin-pack/unix/io.ml | 2 ++ 6 files changed, 17 insertions(+), 7 deletions(-) diff --git a/src/irmin-pack/io/file_manager.ml b/src/irmin-pack/io/file_manager.ml index 3f39e40959..f488c3e5d1 100644 --- a/src/irmin-pack/io/file_manager.ml +++ b/src/irmin-pack/io/file_manager.ml @@ -843,7 +843,7 @@ struct %d; suffix dead bytes %a" generation Int63.pp suffix_start_offset chunk_start_idx chunk_num Int63.pp suffix_dead_bytes]; - let c0 = Mtime_clock.counter () in + let c0 = Io.Clock.counter () in let pl = Control.payload t.control in (* Step 1. Reopen files *) @@ -853,7 +853,7 @@ struct reopen_suffix t ~chunk_start_idx ~chunk_num ~appendable_chunk_poff:pl.appendable_chunk_poff in - let span1 = Mtime_clock.count c0 |> Mtime.span_to_us in + let span1 = Io.Clock.count c0 |> Mtime.span_to_us in (* Step 2. Update the control file *) let* () = @@ -896,7 +896,7 @@ struct Lower.swap ~volume ~generation ~volume_num:pl.volume_num lower) in - let span2 = Mtime_clock.count c0 |> Mtime.span_to_us in + let span2 = Io.Clock.count c0 |> Mtime.span_to_us in [%log.debug "Gc reopen files, update control: %.0fus, %.0fus" span1 (span2 -. span1)]; Ok () diff --git a/src/irmin-pack/io/io_intf.ml b/src/irmin-pack/io/io_intf.ml index 27d55cc1ad..907dd852a0 100644 --- a/src/irmin-pack/io/io_intf.ml +++ b/src/irmin-pack/io/io_intf.ml @@ -163,4 +163,11 @@ module type S = sig val get_stime : unit -> float val get_utime : unit -> float end + + module Clock : sig + type counter + + val counter : unit -> counter + val count : counter -> Mtime.span + end end diff --git a/src/irmin-pack/io/store.ml b/src/irmin-pack/io/store.ml index 0a002c025a..9470c840d6 100644 --- a/src/irmin-pack/io/store.ml +++ b/src/irmin-pack/io/store.ml @@ -423,7 +423,7 @@ struct let readonly = Irmin_pack.Conf.readonly t.config in if readonly then Errs.raise_error `Ro_not_allowed else - let c0 = Mtime_clock.counter () in + let c0 = Io.Clock.counter () in let try_finalise () = Gc.try_auto_finalise_exn t in let _ = try_finalise () in Atomic.set t.during_batch true; @@ -434,7 +434,7 @@ struct let node : 'a Node.t = (contents, node) in let commit : 'a Commit.t = (node, commit) in let on_success res = - let s = Mtime_clock.count c0 |> Mtime.span_to_s in + let s = Io.Clock.count c0 |> Mtime.span_to_s in [%log.info "[pack] batch completed in %.6fs" s]; Atomic.set t.during_batch false; File_manager.flush t.fm |> Errs.raise_if_error; diff --git a/src/irmin-pack/io/traverse_pack_file.ml b/src/irmin-pack/io/traverse_pack_file.ml index eb3592426e..c690673d8d 100644 --- a/src/irmin-pack/io/traverse_pack_file.ml +++ b/src/irmin-pack/io/traverse_pack_file.ml @@ -384,7 +384,7 @@ end = struct let v = create config in (iter_pack_entry ~always v, finalise v, "Checking and fixing index") in - let run_duration = Mtime_clock.counter () in + let run_duration = Io.Clock.counter () in let fm = File_manager.open_ro config |> Errs.raise_if_error in let dispatcher = Dispatcher.v fm |> Errs.raise_if_error in let total = Dispatcher.end_offset dispatcher in @@ -406,7 +406,7 @@ end = struct in finalise (); File_manager.close fm |> Errs.raise_if_error; - let run_duration = Mtime_clock.count run_duration in + let run_duration = Io.Clock.count run_duration in let store_stats fmt = Fmt.pf fmt "Store statistics:@, @[%a@]" Stats.pp stats in diff --git a/src/irmin-pack/unix/dune b/src/irmin-pack/unix/dune index 3e8bb6c693..b446ad6851 100644 --- a/src/irmin-pack/unix/dune +++ b/src/irmin-pack/unix/dune @@ -11,6 +11,7 @@ logs eio mtime + mtime.clock.os cmdliner optint checkseum diff --git a/src/irmin-pack/unix/io.ml b/src/irmin-pack/unix/io.ml index 4443f6270d..0875b5cf3f 100644 --- a/src/irmin-pack/unix/io.ml +++ b/src/irmin-pack/unix/io.ml @@ -327,4 +327,6 @@ module Unix = struct Irmin_pack_io.Stats_intf.Latest_gc. { maxrss; minflt; majflt; inblock; oublock; nvcsw; nivcsw } end + + module Clock = Mtime_clock end From 59deb7c7c03159b8263ff7a774477578939b448e Mon Sep 17 00:00:00 2001 From: ArthurW Date: Mon, 11 Sep 2023 14:55:47 +0200 Subject: [PATCH 82/99] mirage: remove dependency to progress --- src/irmin-pack/io/checks.ml | 22 ++++++----- src/irmin-pack/io/checks_intf.ml | 1 + src/irmin-pack/io/dune | 1 + src/irmin-pack/io/io_intf.ml | 2 + src/irmin-pack/io/store.ml | 2 +- src/irmin-pack/io/traverse_pack_file.ml | 1 + src/irmin-pack/io/utils.ml | 4 +- src/irmin-pack/unix/dune | 1 + src/irmin-pack/unix/io.ml | 50 +++++++++++++++++++++++++ 9 files changed, 73 insertions(+), 11 deletions(-) diff --git a/src/irmin-pack/io/checks.ml b/src/irmin-pack/io/checks.ml index 02aceb80a2..4bc18d56fc 100644 --- a/src/irmin-pack/io/checks.ml +++ b/src/irmin-pack/io/checks.ml @@ -18,7 +18,7 @@ open! Import include Checks_intf let setup_log = - let init style_renderer level = + let init _style_renderer level = let format_reporter = let report _src level ~over k msgf = let k _ = @@ -57,6 +57,7 @@ module Make (Io : Io_intf.S) (Io_index : Index.Platform.S) (Store : Store) = struct module Hash = Store.Hash module Index = Pack_index.Make_io (Io) (Io_index) (Hash) + module Object_counter = Utils.Object_counter (Io.Progress_platform) (** Read basic metrics from an existing store. *) module Stat = struct @@ -75,7 +76,7 @@ struct let index = Index.v_exn ~readonly:true ~fresh:false ~log_size root in let ppf = Format.err_formatter in let bar, (progress_contents, progress_nodes, progress_commits) = - Utils.Object_counter.start ppf + Object_counter.start ppf in let f _ (_, _, (kind : Pack_value.Kind.t)) = match kind with @@ -88,7 +89,7 @@ struct in Index.iter f index; let nb_contents, nb_nodes, nb_commits = - Utils.Object_counter.finalise_with_stats bar + Object_counter.finalise_with_stats bar in { nb_contents; nb_nodes; nb_commits } @@ -380,6 +381,7 @@ struct end module Integrity_checks + (Io : Io_intf.S) (XKey : Pack_key.S) (X : Irmin.Backend.S with type Commit.key = XKey.t @@ -387,6 +389,8 @@ module Integrity_checks and type Schema.Hash.t = XKey.hash) (Index : Pack_index.S) = struct + module Object_counter = Utils.Object_counter (Io.Progress_platform) + let check_always ?ppf ~auto_repair ~check index = let ppf = ppf_or_null ppf in Fmt.pf ppf "Running the integrity_check.\n%!"; @@ -394,7 +398,7 @@ struct let nb_corrupted = ref 0 in let exception Cannot_fix in let counter, (progress_contents, progress_nodes, progress_commits) = - Utils.Object_counter.start ppf + Object_counter.start ppf in let f (k, (offset, length, (kind : Pack_value.Kind.t))) = match kind with @@ -433,7 +437,7 @@ struct if !nb_absent = 0 && !nb_corrupted = 0 then Ok `No_error else Error (`Corrupted (!nb_corrupted + !nb_absent))) in - Utils.Object_counter.finalise counter; + Object_counter.finalise counter; result let check_minimal ?ppf ~pred ~iter ~check ~recompute_hash t = @@ -441,7 +445,7 @@ struct Fmt.pf ppf "Running the integrity_check.\n%!"; let errors = ref [] in let counter, (progress_contents, progress_nodes, progress_commits) = - Utils.Object_counter.start ppf + Object_counter.start ppf in let pp_hash = Irmin.Type.pp X.Hash.t in let equal_hash = Irmin.Type.(unstage (equal X.Hash.t)) in @@ -519,7 +523,7 @@ struct in let () = iter ~contents ~node ~pred_node ~pred_commit t in - Utils.Object_counter.finalise counter; + Object_counter.finalise counter; if !errors = [] then Ok `No_error else Fmt.kstr @@ -532,7 +536,7 @@ struct let ppf = ppf_or_null ppf in Fmt.pf ppf "Check integrity for inodes.\n%!"; let counter, (_, progress_nodes, progress_commits) = - Utils.Object_counter.start ppf + Object_counter.start ppf in let errors = ref [] in let pred_node repo key = @@ -547,7 +551,7 @@ struct in let commit _ = progress_commits () in let () = iter ~pred_node ~node ~commit t in - Utils.Object_counter.finalise counter; + Object_counter.finalise counter; if !errors = [] then Ok `No_error else Fmt.kstr diff --git a/src/irmin-pack/io/checks_intf.ml b/src/irmin-pack/io/checks_intf.ml index 4681f300d1..f62dd361cf 100644 --- a/src/irmin-pack/io/checks_intf.ml +++ b/src/irmin-pack/io/checks_intf.ml @@ -134,6 +134,7 @@ module type Sigs = sig module Make (Io : Io_intf.S) (Io_index : Index.Platform.S) (_ : Store) : S module Integrity_checks + (Io : Io_intf.S) (XKey : Pack_key.S) (X : Irmin.Backend.S with type Commit.key = XKey.t diff --git a/src/irmin-pack/io/dune b/src/irmin-pack/io/dune index cf1bc75095..346df8f863 100644 --- a/src/irmin-pack/io/dune +++ b/src/irmin-pack/io/dune @@ -9,6 +9,7 @@ logs eio mtime + progress.engine cmdliner optint checkseum diff --git a/src/irmin-pack/io/io_intf.ml b/src/irmin-pack/io/io_intf.ml index 907dd852a0..f126a65e45 100644 --- a/src/irmin-pack/io/io_intf.ml +++ b/src/irmin-pack/io/io_intf.ml @@ -170,4 +170,6 @@ module type S = sig val counter : unit -> counter val count : counter -> Mtime.span end + + module Progress_platform : Progress_engine.Platform end diff --git a/src/irmin-pack/io/store.ml b/src/irmin-pack/io/store.ml index 9470c840d6..eb3672e0ba 100644 --- a/src/irmin-pack/io/store.ml +++ b/src/irmin-pack/io/store.ml @@ -482,7 +482,7 @@ struct end include Irmin.Of_backend (X) - module Integrity_checks = Checks.Integrity_checks (XKey) (X) (Index) + module Integrity_checks = Checks.Integrity_checks (Io) (XKey) (X) (Index) let integrity_check_inodes ?heads t = let heads = match heads with None -> Repo.heads t | Some m -> m in diff --git a/src/irmin-pack/io/traverse_pack_file.ml b/src/irmin-pack/io/traverse_pack_file.ml index c690673d8d..84de817531 100644 --- a/src/irmin-pack/io/traverse_pack_file.ml +++ b/src/irmin-pack/io/traverse_pack_file.ml @@ -86,6 +86,7 @@ end = struct open Args module Io = File_manager.Io module Errs = Io_errors.Make (Io) + module Progress = Progress_engine.Make (Io.Progress_platform) let pp_key = Irmin.Type.pp Hash.t let decode_key = Irmin.Type.(unstage (decode_bin Hash.t)) diff --git a/src/irmin-pack/io/utils.ml b/src/irmin-pack/io/utils.ml index 4864349345..b177020a83 100644 --- a/src/irmin-pack/io/utils.ml +++ b/src/irmin-pack/io/utils.ml @@ -16,7 +16,7 @@ open! Import -module Object_counter : sig +module Object_counter (Progress_platform : Progress_engine.Platform) : sig type t val start : @@ -25,6 +25,8 @@ module Object_counter : sig val finalise : t -> unit val finalise_with_stats : t -> int * int * int end = struct + module Progress = Progress_engine.Make (Progress_platform) + type t = | Object_counter : { display : (_, _) Progress.Display.t; diff --git a/src/irmin-pack/unix/dune b/src/irmin-pack/unix/dune index b446ad6851..fa3ae44018 100644 --- a/src/irmin-pack/unix/dune +++ b/src/irmin-pack/unix/dune @@ -12,6 +12,7 @@ eio mtime mtime.clock.os + progress cmdliner optint checkseum diff --git a/src/irmin-pack/unix/io.ml b/src/irmin-pack/unix/io.ml index 0875b5cf3f..db9125581c 100644 --- a/src/irmin-pack/unix/io.ml +++ b/src/irmin-pack/unix/io.ml @@ -329,4 +329,54 @@ module Unix = struct end module Clock = Mtime_clock + + module Progress_platform = struct + module Clock = Mtime_clock + + module Terminal_width = struct + (*———————————————————————————————————————————————————————————————————————————— + Copyright (c) 2020–2021 Craig Ferguson + Distributed under the MIT license. See terms at the end of this file. + ————————————————————————————————————————————————————————————————————————————*) + + let on_change = ref (fun _ -> ()) + let latest_width = ref None + + let initialise = + let handle_signal _ = + let width = Terminal.Size.get_columns () in + latest_width := width; + !on_change width + in + lazy + (latest_width := Terminal.Size.get_columns (); + match Terminal.Size.sigwinch with + | None -> () + | Some n -> Sys.set_signal n (Signal_handle handle_signal)) + + let set_changed_callback f = + Lazy.force initialise; + on_change := f + + let get () = + Lazy.force_val initialise; + !latest_width + + (*———————————————————————————————————————————————————————————————————————————— + Copyright (c) 2020–2021 Craig Ferguson + + 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", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL + THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + DEALINGS IN THE SOFTWARE. + ————————————————————————————————————————————————————————————————————————————*) + end + end end From 2fdb257bbf1c8627f63b8dd7543d09a503a139cb Mon Sep 17 00:00:00 2001 From: ArthurW Date: Wed, 20 Sep 2023 12:51:08 +0200 Subject: [PATCH 83/99] fix progress dependency injection --- src/irmin-pack/io/checks.ml | 4 +- src/irmin-pack/io/io_intf.ml | 2 +- src/irmin-pack/io/traverse_pack_file.ml | 2 +- src/irmin-pack/io/utils.ml | 4 +- src/irmin-pack/unix/io.ml | 51 +------------------------ 5 files changed, 6 insertions(+), 57 deletions(-) diff --git a/src/irmin-pack/io/checks.ml b/src/irmin-pack/io/checks.ml index 4bc18d56fc..493487e4ce 100644 --- a/src/irmin-pack/io/checks.ml +++ b/src/irmin-pack/io/checks.ml @@ -57,7 +57,7 @@ module Make (Io : Io_intf.S) (Io_index : Index.Platform.S) (Store : Store) = struct module Hash = Store.Hash module Index = Pack_index.Make_io (Io) (Io_index) (Hash) - module Object_counter = Utils.Object_counter (Io.Progress_platform) + module Object_counter = Utils.Object_counter (Io.Progress) (** Read basic metrics from an existing store. *) module Stat = struct @@ -389,7 +389,7 @@ module Integrity_checks and type Schema.Hash.t = XKey.hash) (Index : Pack_index.S) = struct - module Object_counter = Utils.Object_counter (Io.Progress_platform) + module Object_counter = Utils.Object_counter (Io.Progress) let check_always ?ppf ~auto_repair ~check index = let ppf = ppf_or_null ppf in diff --git a/src/irmin-pack/io/io_intf.ml b/src/irmin-pack/io/io_intf.ml index f126a65e45..c0cff7f66d 100644 --- a/src/irmin-pack/io/io_intf.ml +++ b/src/irmin-pack/io/io_intf.ml @@ -171,5 +171,5 @@ module type S = sig val count : counter -> Mtime.span end - module Progress_platform : Progress_engine.Platform + module Progress : Progress_engine.S end diff --git a/src/irmin-pack/io/traverse_pack_file.ml b/src/irmin-pack/io/traverse_pack_file.ml index 84de817531..1b0215368d 100644 --- a/src/irmin-pack/io/traverse_pack_file.ml +++ b/src/irmin-pack/io/traverse_pack_file.ml @@ -86,7 +86,7 @@ end = struct open Args module Io = File_manager.Io module Errs = Io_errors.Make (Io) - module Progress = Progress_engine.Make (Io.Progress_platform) + module Progress = Io.Progress let pp_key = Irmin.Type.pp Hash.t let decode_key = Irmin.Type.(unstage (decode_bin Hash.t)) diff --git a/src/irmin-pack/io/utils.ml b/src/irmin-pack/io/utils.ml index b177020a83..29e699da14 100644 --- a/src/irmin-pack/io/utils.ml +++ b/src/irmin-pack/io/utils.ml @@ -16,7 +16,7 @@ open! Import -module Object_counter (Progress_platform : Progress_engine.Platform) : sig +module Object_counter (Progress : Progress_engine.S) : sig type t val start : @@ -25,8 +25,6 @@ module Object_counter (Progress_platform : Progress_engine.Platform) : sig val finalise : t -> unit val finalise_with_stats : t -> int * int * int end = struct - module Progress = Progress_engine.Make (Progress_platform) - type t = | Object_counter : { display : (_, _) Progress.Display.t; diff --git a/src/irmin-pack/unix/io.ml b/src/irmin-pack/unix/io.ml index db9125581c..2ddc92e946 100644 --- a/src/irmin-pack/unix/io.ml +++ b/src/irmin-pack/unix/io.ml @@ -329,54 +329,5 @@ module Unix = struct end module Clock = Mtime_clock - - module Progress_platform = struct - module Clock = Mtime_clock - - module Terminal_width = struct - (*———————————————————————————————————————————————————————————————————————————— - Copyright (c) 2020–2021 Craig Ferguson - Distributed under the MIT license. See terms at the end of this file. - ————————————————————————————————————————————————————————————————————————————*) - - let on_change = ref (fun _ -> ()) - let latest_width = ref None - - let initialise = - let handle_signal _ = - let width = Terminal.Size.get_columns () in - latest_width := width; - !on_change width - in - lazy - (latest_width := Terminal.Size.get_columns (); - match Terminal.Size.sigwinch with - | None -> () - | Some n -> Sys.set_signal n (Signal_handle handle_signal)) - - let set_changed_callback f = - Lazy.force initialise; - on_change := f - - let get () = - Lazy.force_val initialise; - !latest_width - - (*———————————————————————————————————————————————————————————————————————————— - Copyright (c) 2020–2021 Craig Ferguson - - 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", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR - IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, - FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL - THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING - FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER - DEALINGS IN THE SOFTWARE. - ————————————————————————————————————————————————————————————————————————————*) - end - end + module Progress = Progress end From 62051a7b02f7583658f5f053041af0b087f2ff53 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Sat, 7 Oct 2023 12:10:57 +0200 Subject: [PATCH 84/99] irmin-pack: use checkseum.c --- src/irmin-pack/io/dune | 2 +- src/irmin-pack/unix/dune | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/irmin-pack/io/dune b/src/irmin-pack/io/dune index 346df8f863..d647cfadf2 100644 --- a/src/irmin-pack/io/dune +++ b/src/irmin-pack/io/dune @@ -13,7 +13,7 @@ cmdliner optint checkseum - checkseum.ocaml) + checkseum.c) (preprocess (pps ppx_irmin.internal)) (instrumentation diff --git a/src/irmin-pack/unix/dune b/src/irmin-pack/unix/dune index fa3ae44018..39b8458c14 100644 --- a/src/irmin-pack/unix/dune +++ b/src/irmin-pack/unix/dune @@ -16,7 +16,7 @@ cmdliner optint checkseum - checkseum.ocaml + checkseum.c rusage) (preprocess (pps ppx_irmin.internal)) From 18af5b09bdae5b72273d049b4f65ed6ce3df1dcd Mon Sep 17 00:00:00 2001 From: ArthurW Date: Wed, 20 Sep 2023 14:12:45 +0200 Subject: [PATCH 85/99] Update opam dependencies --- .ocamlformat | 2 +- irmin-cli.opam | 10 +++++++--- irmin-fs.opam | 2 +- irmin-git.opam | 8 ++++++-- irmin-graphql.opam | 2 +- irmin-mirage.opam | 2 +- irmin-pack-tools.opam | 8 -------- irmin-pack.opam | 10 ++++------ irmin-server.opam | 7 +++++-- irmin-test.opam | 9 ++++----- irmin.opam | 9 +++------ libirmin.opam | 4 ++-- test/irmin-client/dune | 1 - 13 files changed, 35 insertions(+), 39 deletions(-) diff --git a/.ocamlformat b/.ocamlformat index b405018f05..4904e7748d 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version = 0.26.0 +version = 0.26.1 profile = conventional ocaml-version = 4.08.0 diff --git a/irmin-cli.opam b/irmin-cli.opam index 16640f162a..f42af4c480 100644 --- a/irmin-cli.opam +++ b/irmin-cli.opam @@ -25,9 +25,9 @@ depends: [ "irmin-graphql" {= version} "irmin-tezos" {= version} "irmin-server" {= version} + "irmin-watcher" {= "dev"} "git-unix" {>= "3.7.0"} "digestif" {>= "0.9.0"} - "irmin-watcher" {>= "0.2.0"} "yaml" {>= "3.0.0"} "astring" "astring" @@ -46,14 +46,18 @@ depends: [ "fmt" "git" {>= "3.7.0"} "happy-eyeballs-lwt" - "eio_main" {>= "0.10"} - "lwt_eio" {>= "0.3"} + "eio_main" {>= "0.12"} + "lwt_eio" {>= "0.5"} "lwt" {>= "5.3.0"} "irmin-test" {with-test & = version} "alcotest" {with-test} "mdx" {>= "2.0.0" & with-test} ] +pin-depends: [ + [ "irmin-watcher.dev" "git+https://github.com/patricoferris/irmin-watcher#d0e92b4ba5631b5f4dc0f3c00d97e79542dba45d" ] +] + synopsis: "CLI for Irmin" description: """ A simple CLI tool (called `irmin`) to manipulate and inspect Irmin stores. diff --git a/irmin-fs.opam b/irmin-fs.opam index fd7cca7a34..3faaf7e7ba 100644 --- a/irmin-fs.opam +++ b/irmin-fs.opam @@ -19,7 +19,7 @@ depends: [ "irmin" {= version} "astring" "logs" - "eio" {>= "0.10"} + "eio" {>= "0.15"} "lwt" {>= "5.3.0"} "alcotest" {with-test} "irmin-test" {with-test & = version} diff --git a/irmin-git.opam b/irmin-git.opam index 9367488212..2686aa7ba3 100644 --- a/irmin-git.opam +++ b/irmin-git.opam @@ -29,13 +29,17 @@ depends: [ "fpath" "logs" "lwt" {>= "5.3.0"} - "lwt_eio" {>= "0.3"} + "lwt_eio" {>= "0.5"} "uri" "mimic" "irmin-test" {with-test & = version} "mtime" {with-test & >= "2.0.0"} "alcotest" {with-test} - "irmin-watcher" {>= "0.2.0"} + "irmin-watcher" {= "dev"} +] + +pin-depends: [ + [ "irmin-watcher.dev" "git+https://github.com/patricoferris/irmin-watcher#d0e92b4ba5631b5f4dc0f3c00d97e79542dba45d" ] ] synopsis: "Git backend for Irmin" diff --git a/irmin-graphql.opam b/irmin-graphql.opam index 34b4a14dc4..36bee34c93 100644 --- a/irmin-graphql.opam +++ b/irmin-graphql.opam @@ -27,7 +27,7 @@ depends: [ "git-unix" {>= "3.7.0"} "fmt" "lwt" {>= "5.3.0"} - "lwt_eio" {>= "0.3"} + "lwt_eio" {>= "0.5"} "yojson" {with-test} "alcotest" {with-test & >= "1.2.3"} "logs" {with-test} diff --git a/irmin-mirage.opam b/irmin-mirage.opam index 1cb917d92e..29983a8022 100644 --- a/irmin-mirage.opam +++ b/irmin-mirage.opam @@ -18,7 +18,7 @@ depends: [ "fmt" "ptime" "mirage-clock" {>= "3.0.0"} - "lwt_eio" {>= "0.3"} + "lwt_eio" {>= "0.5"} ] synopsis: "MirageOS-compatible Irmin stores" diff --git a/irmin-pack-tools.opam b/irmin-pack-tools.opam index 4c0c4da7fd..bc72445124 100644 --- a/irmin-pack-tools.opam +++ b/irmin-pack-tools.opam @@ -33,14 +33,6 @@ depends: [ "alcotest" {with-test} ] -pin-depends: [ - # Needed by Index - [ "terminal.dev" "git+https://github.com/craigfe/progress#76e7c791bd17c28b3e605d9c383102a30345e029" ] - [ "progress.dev" "git+https://github.com/craigfe/progress#76e7c791bd17c28b3e605d9c383102a30345e029" ] - # Needed by Irmin-pack - # [ "index.dev" "git+https://github.com/patricoferris/index#cfa32e984b633d08b2f0c1fc1f792925c6d74f8e" ] -] - synopsis: "Utils for Irmin-pack" description: """ `Irmin-pack-tools` defines useful binaries and libraries for diff --git a/irmin-pack.opam b/irmin-pack.opam index a1428f2f29..6659a320bf 100644 --- a/irmin-pack.opam +++ b/irmin-pack.opam @@ -20,7 +20,7 @@ depends: [ "index" {= "dev"} "fmt" "logs" - "eio" {>= "0.10"} + "eio" {>= "0.15"} "mtime" {>= "2.0.0"} "cmdliner" "optint" {>= "0.1.0"} @@ -32,11 +32,9 @@ depends: [ ] pin-depends: [ - # Needed by Index - [ "terminal.dev" "git+https://github.com/craigfe/progress#76e7c791bd17c28b3e605d9c383102a30345e029" ] - [ "progress.dev" "git+https://github.com/craigfe/progress#76e7c791bd17c28b3e605d9c383102a30345e029" ] - # Needed by Irmin-pack - # [ "index.dev" "git+https://github.com/patricoferris/index#cfa32e984b633d08b2f0c1fc1f792925c6d74f8e" ] + [ "terminal.dev" "git+https://github.com/craigfe/progress#ac53cd48cd82500f51faf67f9555a9454d5f5504" ] + [ "progress.dev" "git+https://github.com/craigfe/progress#ac53cd48cd82500f51faf67f9555a9454d5f5504" ] + [ "index.dev" "git+https://github.com/mirage/index#09ab315dcfe6c1affbbb01c737f1b8e235b04eca" ] ] synopsis: "Irmin backend which stores values in a pack file" diff --git a/irmin-server.opam b/irmin-server.opam index 540c3631a3..52e7df8990 100644 --- a/irmin-server.opam +++ b/irmin-server.opam @@ -24,11 +24,14 @@ depends: [ "cohttp-lwt-unix" "ppx_blob" {>= "0.7.2"} "digestif" {>= "1.1.4"} - "alcotest-lwt" {>= "1.7.0" & with-test} - "irmin-watcher" {>= "0.5.0" & with-test} + "irmin-watcher" {= "dev" & with-test} "irmin-test" {= version & with-test} ] +pin-depends: [ + [ "irmin-watcher.dev" "git+https://github.com/patricoferris/irmin-watcher#d0e92b4ba5631b5f4dc0f3c00d97e79542dba45d" ] +] + build: [ ["dune" "subst"] {pinned} ["dune" "build" "-p" name "-j" jobs] diff --git a/irmin-test.opam b/irmin-test.opam index 150b0c009d..cd0b498edc 100644 --- a/irmin-test.opam +++ b/irmin-test.opam @@ -23,14 +23,14 @@ depends: [ "jsonm" "logs" "lwt" {>= "5.3.0"} - "eio" {>= "0.10"} - "eio_main" {>= "0.10"} + "eio" {>= "0.15"} + "eio_main" {>= "0.15"} "alcotest" {>= "dev"} "qcheck-alcotest" {with-test & >= "0.21.1"} - "metrics-unix" + "metrics" {>= "0.4.1"} + "metrics-unix" {>= "0.4.1"} "ocaml-syntax-shims" "cmdliner" - "metrics" {>= "0.2.0"} "hex" {with-test & >= "1.4.0"} "vector" {with-test & >= "1.0.0"} "alcotest" {>= "1.7.0" & with-test} @@ -40,7 +40,6 @@ depends: [ pin-depends: [ # Fix race in formatters [ "alcotest.dev" "git+https://github.com/haesbaert/alcotest#99030be1df12a17fc2a0f3d00b181cd31cf6b0d4" ] - [ "alcotest-lwt.dev" "git+https://github.com/haesbaert/alcotest#99030be1df12a17fc2a0f3d00b181cd31cf6b0d4" ] ] synopsis: "Irmin test suite" diff --git a/irmin.opam b/irmin.opam index 4c58a2bc73..2398bfb0d8 100644 --- a/irmin.opam +++ b/irmin.opam @@ -21,7 +21,7 @@ depends: [ "uri" {>= "1.3.12"} "uutf" "jsonm" {>= "1.0.0"} - "eio" {>= "0.6"} + "eio" {>= "0.15"} "lwt" {>= "5.6.1"} "digestif" {>= "0.9.0"} "ocamlgraph" @@ -31,9 +31,10 @@ depends: [ "mtime" {>= "2.0.0"} "bigstringaf" { >= "0.2.0" } "ppx_irmin" {= version} + "eio_main" {>= "0.15" & with-test} "hex" {with-test} "alcotest" {= "dev" & with-test} - "eio_main" {>= "0.2" & with-test} + "eio_main" {>= "0.5" & with-test} "qcheck-alcotest" {with-test} "vector" {with-test} "odoc" {(< "2.0.1" | > "2.0.2") & with-doc} # See https://github.com/ocaml/odoc/issues/793 @@ -41,12 +42,8 @@ depends: [ ] pin-depends: [ - # Metrics may have been unnecessarily constrained in opam-repository - [ "metrics.dev" "git+https://github.com/mirage/metrics#995eb18d2837df02c8ead719c00fb156cf475ab5"] - [ "metrics-unix.dev" "git+https://github.com/mirage/metrics#995eb18d2837df02c8ead719c00fb156cf475ab5"] # Fix race in formatters [ "alcotest.dev" "git+https://github.com/haesbaert/alcotest#99030be1df12a17fc2a0f3d00b181cd31cf6b0d4" ] - [ "alcotest-lwt.dev" "git+https://github.com/haesbaert/alcotest#99030be1df12a17fc2a0f3d00b181cd31cf6b0d4" ] ] conflicts: [ diff --git a/libirmin.opam b/libirmin.opam index b7953ffd94..ebff1f20c4 100644 --- a/libirmin.opam +++ b/libirmin.opam @@ -12,8 +12,8 @@ depends: [ "ctypes-foreign" {>= "0.18"} "irmin" {= version} "irmin-cli" {= version} - "eio_main" {>= "0.10"} - "lwt_eio" {>= "0.3"} + "eio_main" {>= "0.12"} + "lwt_eio" {>= "0.5"} ] build: [ ["dune" "subst"] {dev} diff --git a/test/irmin-client/dune b/test/irmin-client/dune index 0a2920ca17..e373485974 100644 --- a/test/irmin-client/dune +++ b/test/irmin-client/dune @@ -7,6 +7,5 @@ irmin-client.unix websocket-lwt-unix conduit-lwt-unix - alcotest-lwt irmin-test irmin-watcher)) From 855be857ffcf8658c46c335c3b97836499f407c1 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Wed, 21 Feb 2024 14:49:03 +0100 Subject: [PATCH 86/99] Fix irmin-client tests --- test/irmin-client/test.ml | 17 ++++++++--------- test/irmin-client/util.ml | 21 +++++++-------------- 2 files changed, 15 insertions(+), 23 deletions(-) diff --git a/test/irmin-client/test.ml b/test/irmin-client/test.ml index e51a869c95..606a9a4110 100644 --- a/test/irmin-client/test.ml +++ b/test/irmin-client/test.ml @@ -27,13 +27,11 @@ let () = Logs.set_reporter (Logs_fmt.reporter ()) module type R = sig - val pid : int val uri : Uri.t val kind : string end module Make (R : R) = struct - let () = at_exit (fun () -> try Unix.kill R.pid Sys.sigint with _ -> ()) let config = Irmin_client_unix.config R.uri module X = Irmin_mem.KV.Make (Irmin.Contents.String) @@ -67,21 +65,22 @@ let ping client () = let misc client = [ ("ping", `Quick, ping client) ] let misc client = [ ("misc", misc client) ] -let main () = - let kind, pid, uri = run_server `Unix_domain in +let main ~env () = + let clock = Eio.Stdenv.clock env in + Eio.Switch.run @@ fun sw -> + let kind, uri = run_server ~sw ~clock `Unix_domain in let config = Irmin_client_unix.config uri in let client = Client.Repo.v config in let client () = Lwt_eio.run_lwt @@ fun () -> Client.dup client in let module Unix_socket = Make (struct - let pid = pid let uri = uri let kind = kind end) in let module Tcp_socket = Make (struct - let kind, pid, uri = run_server `Tcp + let kind, uri = run_server ~sw ~clock `Tcp end) in let module Websocket = Make (struct - let kind, pid, uri = run_server `Websocket + let kind, uri = run_server ~sw ~clock `Websocket end) in let slow = Sys.getenv_opt "SLOW" |> Option.is_some in let only = Sys.getenv_opt "ONLY" in @@ -93,8 +92,8 @@ let main () = | Some s -> failwith ("Invalid selection: " ^ s) | None -> [ - (`Quick, Unix_socket.suite ()); (`Quick, Tcp_socket.suite ()); + (`Quick, Unix_socket.suite ()); (`Quick, Websocket.suite ()); ] in @@ -103,4 +102,4 @@ let main () = let () = Eio_main.run @@ fun env -> - Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> main () + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> main ~env () diff --git a/test/irmin-client/util.ml b/test/irmin-client/util.ml index 4b89c768aa..466beb1b7c 100644 --- a/test/irmin-client/util.ml +++ b/test/irmin-client/util.ml @@ -23,7 +23,7 @@ let test name f client _switch () = Logs.debug (fun l -> l "Running: %s" name); f client -let run_server s = +let run_server ~sw ~clock s = let kind, uri = match s with | `Websocket -> ("Websocket", Uri.of_string "ws://localhost:90991") @@ -33,18 +33,11 @@ let run_server s = ("Unix_domain", Uri.of_string ("unix://" ^ sock)) | `Tcp -> ("Tcp", Uri.of_string "tcp://localhost:90992") in - match Lwt_unix.fork () with - | 0 -> + Eio.Fiber.fork_daemon ~sw (fun () -> let () = Irmin.Backend.Watch.set_listen_dir_hook Irmin_watcher.hook in - let conf = Irmin_mem.config () in + let key = Irmin.Backend.Conf.root Irmin_mem.Conf.spec in + let conf = Irmin.Backend.Conf.singleton Irmin_mem.Conf.spec key kind in Lwt_eio.run_lwt (fun () -> Server.v ~uri conf >>= Server.serve); - (kind, 0, uri) - | n -> - Unix.sleep 3; - (kind, n, uri) - -let suite client all = - List.map - (fun (name, speed, f) -> - Alcotest_lwt.test_case name speed (test name f client)) - all + `Stop_daemon); + Eio.Time.sleep clock 0.1; + (kind, uri) From 1e877142c8bff5dfe6c2b27b9ca4db530a20a79c Mon Sep 17 00:00:00 2001 From: ArthurW Date: Wed, 28 Feb 2024 11:39:55 +0100 Subject: [PATCH 87/99] Simplify concurrent list operations --- src/irmin-chunk/irmin_chunk.ml | 3 ++- src/irmin/import.ml | 10 ---------- src/irmin/store.ml | 17 ++++++----------- 3 files changed, 8 insertions(+), 22 deletions(-) diff --git a/src/irmin-chunk/irmin_chunk.ml b/src/irmin-chunk/irmin_chunk.ml index a8331dddf0..e17b1274a6 100644 --- a/src/irmin-chunk/irmin_chunk.ml +++ b/src/irmin-chunk/irmin_chunk.ml @@ -179,7 +179,8 @@ struct | [ i ] -> AO.add t.db key (index t i); key - | l -> Fiber.List.map (fun i -> CA.add t.db (index t i)) l |> aux) + | l -> + Eio.Fiber.List.map (fun i -> CA.add t.db (index t i)) l |> aux) in aux l end diff --git a/src/irmin/import.ml b/src/irmin/import.ml index 2c4744ce50..a5e2e3b39b 100644 --- a/src/irmin/import.ml +++ b/src/irmin/import.ml @@ -23,16 +23,6 @@ type read_write = Perms.read_write (** {2 Dependency extensions} *) -module Fiber = struct - include Eio.Fiber - (** @closed *) - - let all_p fs = - Eio.Switch.run @@ fun sw -> - let ps = List.map (fork_promise ~sw) fs in - List.map Eio.Promise.await_exn ps -end - module Option = struct include Option (** @closed *) diff --git a/src/irmin/store.ml b/src/irmin/store.ml index 4dde08c54d..60d9a04893 100644 --- a/src/irmin/store.ml +++ b/src/irmin/store.ml @@ -986,9 +986,7 @@ module Make (B : Backend.S) = struct let return_lcas r = function | Error _ as e -> e | Ok commits -> - List.map (fun v () -> Commit.of_key r v) commits - |> Fiber.all_p - |> List.filter_map (fun v -> v) + Eio.Fiber.List.filter_map (fun v -> Commit.of_key r v) commits |> Result.ok let lcas ?max_depth ?n t1 t2 = @@ -1079,12 +1077,10 @@ module Make (B : Backend.S) = struct [%log.debug "history"]; let pred = function | `Commit k -> - List.map - (fun v () -> Commit.of_key t.repo v) + Eio.Fiber.List.filter_map + (fun v -> Commit.of_key t.repo v) (Commits.parents (commit_store t) k) - |> Fiber.all_p - |> List.filter_map (fun v -> v) - |> fun parents -> List.map (fun x -> `Commit x.key) parents + |> List.map (fun x -> `Commit x.key) | _ -> [] in let max = Head.find t |> function Some h -> [ h ] | None -> max in @@ -1130,8 +1126,8 @@ module Make (B : Backend.S) = struct | None -> false in let found = - List.map - (fun hash () -> + Eio.Fiber.List.map + (fun hash -> match Commit.of_key repo hash with | Some commit -> ( let () = @@ -1147,7 +1143,6 @@ module Make (B : Backend.S) = struct | _, _ -> false) | None -> false) parents - |> Fiber.all_p |> List.for_all Fun.id in if found then search (current :: acc) else search acc From c7b22e38113e9ae34266130fe7926ad229de16a7 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Tue, 5 Mar 2024 13:19:10 +0100 Subject: [PATCH 88/99] Fix CI opam dependencies --- examples/dune | 2 ++ irmin-client.opam | 4 ++++ irmin-pack.opam | 1 + irmin-server.opam | 2 ++ 4 files changed, 9 insertions(+) diff --git a/examples/dune b/examples/dune index 3d0e18031e..4370e92b32 100644 --- a/examples/dune +++ b/examples/dune @@ -15,7 +15,9 @@ astring cohttp fmt + irmin irmin.unix + irmin-client.unix irmin-git.unix irmin-graphql.unix irmin-pack.unix diff --git a/irmin-client.opam b/irmin-client.opam index ceb76e0446..8c61db9273 100644 --- a/irmin-client.opam +++ b/irmin-client.opam @@ -22,6 +22,10 @@ depends: [ "logs" {>= "0.7.0"} "lwt" {>= "5.7.0"} "irmin-test" {= version & with-test} + "irmin-watcher" {= "dev" & with-test} +] +pin-depends: [ + [ "irmin-watcher.dev" "git+https://github.com/patricoferris/irmin-watcher#d0e92b4ba5631b5f4dc0f3c00d97e79542dba45d" ] ] build: [ ["dune" "subst"] {pinned} diff --git a/irmin-pack.opam b/irmin-pack.opam index 6659a320bf..8e20448e23 100644 --- a/irmin-pack.opam +++ b/irmin-pack.opam @@ -26,6 +26,7 @@ depends: [ "optint" {>= "0.1.0"} "checkseum" "rusage" + "progress" {= "dev"} "irmin-test" {with-test & = version} "astring" {with-test} "alcotest" {with-test} diff --git a/irmin-server.opam b/irmin-server.opam index 52e7df8990..28f639a48c 100644 --- a/irmin-server.opam +++ b/irmin-server.opam @@ -18,6 +18,8 @@ depends: [ "fmt" "cmdliner" {>= "1.0.4"} "logs" {>= "0.7.0"} + "eio_main" {>= "0.15"} + "lwt_eio" {>= "0.5.1"} "lwt" {>= "5.4.0"} "conduit-lwt-unix" {>= "6.0.0"} "websocket-lwt-unix" From 05a4af321293f892ddb72b5ff075aeec25416808 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Tue, 5 Mar 2024 15:29:25 +0100 Subject: [PATCH 89/99] Upgrade dune and fix new warnings --- bench/irmin-pack/tree.ml | 4 +--- dune | 16 ++++++++++++++-- dune-project | 4 ++-- examples/custom_merge.ml | 1 - examples/dune | 4 +--- examples/process.ml | 6 ++---- examples/trees.ml | 2 +- irmin-bench.opam | 2 +- irmin-chunk.opam | 2 +- irmin-cli.opam | 2 +- irmin-client.opam | 2 +- irmin-containers.opam | 2 +- irmin-fs.opam | 2 +- irmin-git.opam | 2 +- irmin-graphql.opam | 2 +- irmin-http.opam | 2 +- irmin-mirage-git.opam | 2 +- irmin-mirage-graphql.opam | 2 +- irmin-mirage.opam | 2 +- irmin-pack-tools.opam | 2 +- irmin-pack.opam | 2 +- irmin-server.opam | 2 +- irmin-test.opam | 2 +- irmin-tezos.opam | 2 +- irmin.opam | 2 +- libirmin.opam | 2 +- ppx_irmin.opam | 2 +- src/irmin-client/unix/bin/client.ml | 5 ----- src/irmin-containers/linked_log.ml | 13 ++++--------- src/irmin-git/backend.ml | 6 +----- src/irmin-mirage/git/irmin_mirage_git.ml | 14 +++++--------- src/irmin-pack/io/gc.ml | 12 +++--------- src/irmin-pack/io/sparse_file.ml | 9 ++------- src/irmin-pack/io/store.ml | 2 -- src/irmin-server/unix/server.ml | 2 +- src/irmin-test/irmin_bench.ml | 4 +--- src/irmin/lru.ml | 2 +- src/irmin/mem/irmin_mem.ml | 4 ++-- src/irmin/metrics.ml | 1 + test/irmin-client/test.ml | 7 ------- test/irmin-pack/test_inode.ml | 3 +-- 41 files changed, 63 insertions(+), 98 deletions(-) diff --git a/bench/irmin-pack/tree.ml b/bench/irmin-pack/tree.ml index a3fbfa6bd8..dda91d9496 100644 --- a/bench/irmin-pack/tree.ml +++ b/bench/irmin-pack/tree.ml @@ -29,7 +29,6 @@ type config = { path_conversion : [ `None | `V1 | `V0_and_v1 | `V0 ]; inode_config : int * int; store_type : [ `Pack | `Pack_mem ]; - freeze_commit : int; replay_trace_path : string; artefacts_path : string; keep_store : bool; @@ -400,7 +399,7 @@ let get_suite suite_filter = suite let main () ncommits number_of_commits_to_replay suite_filter inode_config - store_type freeze_commit path_conversion depth width nchain_trees + store_type _freeze_commit path_conversion depth width nchain_trees nlarge_trees replay_trace_path artefacts_path keep_store keep_stat_trace no_summary empty_blobs gc_every gc_distance_in_the_past gc_wait_after add_volume_every = @@ -421,7 +420,6 @@ let main () ncommits number_of_commits_to_replay suite_filter inode_config replay_trace_path; inode_config; store_type; - freeze_commit; artefacts_path; keep_store; keep_stat_trace; diff --git a/dune b/dune index 494db1796a..5d635dbe65 100644 --- a/dune +++ b/dune @@ -1,6 +1,18 @@ (vendored_dirs vendors irmin-watcher.dev ocaml-inotify) +(env + (dev + (flags :standard -w -unused-functor-parameter))) + (mdx (files README.md) - (package irmin-cli) - (packages irmin-cli)) + (deps %{bin:irmin}) + (libraries + irmin + irmin-cli + irmin-git + irmin-git.unix + eio + eio_main + eio.unix + lwt_eio)) diff --git a/dune-project b/dune-project index f9600ff68f..b510b99b45 100644 --- a/dune-project +++ b/dune-project @@ -1,4 +1,4 @@ -(lang dune 2.9) +(lang dune 3.5) (name irmin) (cram enable) -(using mdx 0.1) +(using mdx 0.2) diff --git a/examples/custom_merge.ml b/examples/custom_merge.ml index a19806cc83..868f0dc7be 100644 --- a/examples/custom_merge.ml +++ b/examples/custom_merge.ml @@ -27,7 +27,6 @@ let what = \ - concatenate `lca` and `l3`; This gives the final result." let time = ref 0L -let failure fmt = Fmt.kstr failwith fmt (* A log entry *) module Entry : sig diff --git a/examples/dune b/examples/dune index 4370e92b32..28f453fd47 100644 --- a/examples/dune +++ b/examples/dune @@ -62,6 +62,4 @@ (mdx (files merkle_proofs.md) - ; (preludes merkle_proofs_prelude.ml) - (package irmin-cli) - (packages irmin-cli)) + (libraries irmin irmin-cli irmin-git.unix ppx_irmin)) diff --git a/examples/process.ml b/examples/process.ml index 664ce841c0..a24c5cac85 100644 --- a/examples/process.ml +++ b/examples/process.ml @@ -16,10 +16,6 @@ (* Simple UI example: connect to http://localhost:8080/dump *) -let fin () = - let _ = Fmt.kstr Sys.command "cd %s && git reset HEAD --hard" Config.root in - Lwt.return_unit - type action = { message : string; files : (string list * (unit -> string)) list; @@ -27,6 +23,7 @@ type action = { type image = { name : string; actions : action list } +(* let ubuntu = { name = "official-images/ubuntu:14.04"; @@ -44,6 +41,7 @@ let ubuntu = { message = "cat /etc/issue"; files = [] }; ]; } +*) let wordpress = { diff --git a/examples/trees.ml b/examples/trees.ml index c0f68fc005..88a60f411c 100644 --- a/examples/trees.ml +++ b/examples/trees.ml @@ -25,7 +25,7 @@ type t1 = int type t2 = { x : string; y : t1 } type t = t2 list -let tree_of_t t = +let tree_of_t (t : t) = let tree, _ = List.fold_left (fun (v, i) t2 -> diff --git a/irmin-bench.opam b/irmin-bench.opam index 2e02920cf5..dcfcb6d017 100644 --- a/irmin-bench.opam +++ b/irmin-bench.opam @@ -13,7 +13,7 @@ build: [ ] depends: [ - "dune" {>= "2.9.0"} + "dune" {>= "3.5.0"} "irmin-pack" {= version} "irmin-test" {= version} "irmin-tezos" {= version} diff --git a/irmin-chunk.opam b/irmin-chunk.opam index 63812ee2a1..756ec81ad0 100644 --- a/irmin-chunk.opam +++ b/irmin-chunk.opam @@ -14,7 +14,7 @@ build: [ depends: [ "ocaml" {>= "4.02.3"} - "dune" {>= "2.9.0"} + "dune" {>= "3.5.0"} "irmin" {= version} "fmt" "logs" diff --git a/irmin-cli.opam b/irmin-cli.opam index f42af4c480..9605496d22 100644 --- a/irmin-cli.opam +++ b/irmin-cli.opam @@ -17,7 +17,7 @@ available: arch != "arm32" & arch != "x86_32" depends: [ "ocaml" {>= "4.01.0"} - "dune" {>= "2.9.0"} + "dune" {>= "3.5.0"} "irmin" {= version} "irmin-git" {= version} "irmin-fs" {= version} diff --git a/irmin-client.opam b/irmin-client.opam index 8c61db9273..696e617c27 100644 --- a/irmin-client.opam +++ b/irmin-client.opam @@ -9,7 +9,7 @@ dev-repo: "git+ssh://github.com/mirage/irmin" bug-reports: "https://github.com/mirage/irmin/issues" depends: [ "ocaml" {>= "4.08.0"} - "dune" {>= "2.9.0"} + "dune" {>= "3.5.0"} "irmin-server" {= version} "irmin-cli" {= version} "ipaddr" diff --git a/irmin-containers.opam b/irmin-containers.opam index c0f5052191..500d4d5b15 100644 --- a/irmin-containers.opam +++ b/irmin-containers.opam @@ -15,7 +15,7 @@ build: [ depends: [ "ocaml" {>= "4.03.0"} - "dune" {>= "2.9.0"} + "dune" {>= "3.5.0"} "irmin" {= version} "irmin-fs" {= version} "ppx_irmin" {= version} diff --git a/irmin-fs.opam b/irmin-fs.opam index 3faaf7e7ba..1461afb86e 100644 --- a/irmin-fs.opam +++ b/irmin-fs.opam @@ -15,7 +15,7 @@ build: [ depends: [ "ocaml" {>= "4.03.0"} - "dune" {>= "2.9.0"} + "dune" {>= "3.5.0"} "irmin" {= version} "astring" "logs" diff --git a/irmin-git.opam b/irmin-git.opam index 2686aa7ba3..6f0f202c22 100644 --- a/irmin-git.opam +++ b/irmin-git.opam @@ -16,7 +16,7 @@ build: [ depends: [ "ocaml" {>= "4.02.3"} - "dune" {>= "2.9.0"} + "dune" {>= "3.5.0"} "irmin" {= version} "ppx_irmin" {= version} "git" {>= "3.14.0"} diff --git a/irmin-graphql.opam b/irmin-graphql.opam index 36bee34c93..7b1533bf46 100644 --- a/irmin-graphql.opam +++ b/irmin-graphql.opam @@ -15,7 +15,7 @@ build: [ depends: [ "ocaml" {>= "4.03.0"} - "dune" {>= "2.9.0"} + "dune" {>= "3.5.0"} "irmin" {= version} "graphql" {>= "0.14.0"} "graphql-lwt" {>= "0.14.0"} diff --git a/irmin-http.opam b/irmin-http.opam index a3ec718301..541cda4805 100644 --- a/irmin-http.opam +++ b/irmin-http.opam @@ -15,7 +15,7 @@ build: [ depends: [ "ocaml" {>= "4.02.3"} - "dune" {>= "2.9.0"} + "dune" {>= "3.5.0"} "crunch" {>= "2.2.0"} "webmachine" {>= "0.6.0"} "irmin" {= version} diff --git a/irmin-mirage-git.opam b/irmin-mirage-git.opam index 2625da8f05..ab3a0be7ca 100644 --- a/irmin-mirage-git.opam +++ b/irmin-mirage-git.opam @@ -13,7 +13,7 @@ build: [ ] depends: [ - "dune" {>= "2.9.0"} + "dune" {>= "3.5.0"} "irmin-mirage" {= version} "irmin-git" {= version} "mirage-kv" {>= "6.0.0"} diff --git a/irmin-mirage-graphql.opam b/irmin-mirage-graphql.opam index da6926a618..876a7047ec 100644 --- a/irmin-mirage-graphql.opam +++ b/irmin-mirage-graphql.opam @@ -13,7 +13,7 @@ build: [ ] depends: [ - "dune" {>= "2.9.0"} + "dune" {>= "3.5.0"} "irmin-mirage" {= version} "irmin-graphql" {= version} "mirage-clock" diff --git a/irmin-mirage.opam b/irmin-mirage.opam index 29983a8022..19323e2fa0 100644 --- a/irmin-mirage.opam +++ b/irmin-mirage.opam @@ -13,7 +13,7 @@ build: [ ] depends: [ - "dune" {>= "2.9.0"} + "dune" {>= "3.5.0"} "irmin" {= version} "fmt" "ptime" diff --git a/irmin-pack-tools.opam b/irmin-pack-tools.opam index bc72445124..1589e1f5a8 100644 --- a/irmin-pack-tools.opam +++ b/irmin-pack-tools.opam @@ -17,7 +17,7 @@ available: arch != "arm32" & arch != "x86_32" depends: [ "ocaml" {>= "4.01.0"} - "dune" {>= "2.9.0"} + "dune" {>= "3.5.0"} "irmin-tezos" {= version} "irmin-pack" {= version} "irmin-pack" {= version} diff --git a/irmin-pack.opam b/irmin-pack.opam index 8e20448e23..c92fda6ec4 100644 --- a/irmin-pack.opam +++ b/irmin-pack.opam @@ -14,7 +14,7 @@ build: [ depends: [ "ocaml" {>= "4.12.0"} - "dune" {>= "2.9.0"} + "dune" {>= "3.5.0"} "irmin" {= version} "ppx_irmin" {= version} "index" {= "dev"} diff --git a/irmin-server.opam b/irmin-server.opam index 28f639a48c..16eac0106a 100644 --- a/irmin-server.opam +++ b/irmin-server.opam @@ -9,7 +9,7 @@ dev-repo: "git+ssh://github.com/mirage/irmin" bug-reports: "https://github.com/mirage/irmin/issues" depends: [ "ocaml" {>= "4.08.0"} - "dune" {>= "2.9.0"} + "dune" {>= "3.5.0"} "optint" {>= "0.1.0"} "irmin" {= version} "ppx_irmin" {= version} diff --git a/irmin-test.opam b/irmin-test.opam index cd0b498edc..3248aa8067 100644 --- a/irmin-test.opam +++ b/irmin-test.opam @@ -16,7 +16,7 @@ depends: [ "irmin" {= version} "ppx_irmin" {= version} "ocaml" {>= "4.02.3"} - "dune" {>= "2.9.0"} + "dune" {>= "3.5.0"} "mtime" {>= "2.0.0"} "astring" "fmt" diff --git a/irmin-tezos.opam b/irmin-tezos.opam index 740f749e6b..d47ba7bcd3 100644 --- a/irmin-tezos.opam +++ b/irmin-tezos.opam @@ -7,7 +7,7 @@ license: "ISC" homepage: "https://github.com/mirage/irmin" bug-reports: "https://github.com/mirage/irmin/issues" depends: [ - "dune" {>= "2.9.0"} + "dune" {>= "3.5.0"} "irmin" {>= version} "irmin-pack" {= version} "ppx_irmin" {= version} diff --git a/irmin.opam b/irmin.opam index 2398bfb0d8..69efbea17f 100644 --- a/irmin.opam +++ b/irmin.opam @@ -15,7 +15,7 @@ build: [ depends: [ "ocaml" {>= "4.08.0"} - "dune" {>= "2.9.0"} + "dune" {>= "3.5.0"} "repr" {>= "0.6.0"} "fmt" {>= "0.8.5"} "uri" {>= "1.3.12"} diff --git a/libirmin.opam b/libirmin.opam index ebff1f20c4..8623f68cd3 100644 --- a/libirmin.opam +++ b/libirmin.opam @@ -7,7 +7,7 @@ license: "ISC" homepage: "https://github.com/mirage/irmin" bug-reports: "https://github.com/mirage/irmin/issues" depends: [ - "dune" {>= "2.9"} + "dune" {>= "3.5.0"} "ctypes" {>= "0.19"} "ctypes-foreign" {>= "0.18"} "irmin" {= version} diff --git a/ppx_irmin.opam b/ppx_irmin.opam index ed6b33542c..713d1738ea 100644 --- a/ppx_irmin.opam +++ b/ppx_irmin.opam @@ -14,7 +14,7 @@ build: [ depends: [ "ocaml" {>= "4.10.0"} - "dune" {>= "2.9.0"} + "dune" {>= "3.5.0"} "ppx_repr" {>= "0.2.0"} "ppxlib" {>= "0.12.0"} "logs" {>= "0.5.0"} diff --git a/src/irmin-client/unix/bin/client.ml b/src/irmin-client/unix/bin/client.ml index e80a3cb11b..8ac3c90651 100644 --- a/src/irmin-client/unix/bin/client.ml +++ b/src/irmin-client/unix/bin/client.ml @@ -217,7 +217,6 @@ let watch client = x let watch client = watch client false 0 -let pr_str = Format.pp_print_string let path index = let doc = Arg.info ~docv:"PATH" ~doc:"Path to lookup or modify" [] in @@ -261,10 +260,6 @@ let iterations = in Arg.(value @@ opt int 1 doc) -let freq = - let doc = Arg.info ~doc:"Update frequency" [ "f"; "freq" ] in - Arg.(value @@ opt float 5. doc) - let config = let create uri (branch : string option) tls (store, hash, contents) codec config_path () = diff --git a/src/irmin-containers/linked_log.ml b/src/irmin-containers/linked_log.ml index 1bcb7d3143..30ffbd789b 100644 --- a/src/irmin-containers/linked_log.ml +++ b/src/irmin-containers/linked_log.ml @@ -112,12 +112,7 @@ struct module HashSet = Set.Make (Set_elt) type value = V.t - - type cursor = { - seen : HashSet.t; - cache : Log_item(T)(H)(V).t list; - store : Store.t; - } + type cursor = { seen : HashSet.t; cache : Log_item(T)(H)(V).t list } let empty_info = Store.Info.none @@ -127,7 +122,7 @@ struct Store.set_exn ~info:empty_info t path v let get_cursor ~path store = - let mk_cursor seen cache = { seen; cache; store } in + let mk_cursor seen cache = { seen; cache } in match Store.find store path with | None -> mk_cursor HashSet.empty [] | Some k -> ( @@ -150,11 +145,11 @@ struct match L.read_key pk with | Value v -> read_log - { cursor with seen; cache = L.sort (v :: xs) } + { seen; cache = L.sort (v :: xs) } (num_items - 1) (msg :: acc) | Merge l -> read_log - { cursor with seen; cache = L.sort (l @ xs) } + { seen; cache = L.sort (l @ xs) } (num_items - 1) (msg :: acc)) let read ~num_items cursor = read_log cursor num_items [] diff --git a/src/irmin-git/backend.ml b/src/irmin-git/backend.ml index f4c76e09d3..51bd43a32b 100644 --- a/src/irmin-git/backend.ml +++ b/src/irmin-git/backend.ml @@ -84,8 +84,6 @@ struct type config = { root : string; dot_git : string option; - level : int option; - buffers : int option; head : G.Reference.t option; bare : bool; } @@ -94,11 +92,9 @@ struct let module C = Irmin.Backend.Conf in let root = C.find_root c |> Option.value ~default:"." in let dot_git = C.get c Conf.Key.dot_git in - let level = C.get c Conf.Key.level in let head = C.get c Conf.Key.head in let bare = C.get c Conf.Key.bare in - let buffers = C.get c Conf.Key.buffers in - { root; dot_git; level; head; buffers; bare } + { root; dot_git; head; bare } let fopt f = function None -> None | Some x -> Some (f x) diff --git a/src/irmin-mirage/git/irmin_mirage_git.ml b/src/irmin-mirage/git/irmin_mirage_git.ml index 34980b2c69..8a7266738f 100644 --- a/src/irmin-mirage/git/irmin_mirage_git.ml +++ b/src/irmin-mirage/git/irmin_mirage_git.ml @@ -105,7 +105,7 @@ module KV_RO (G : Git.S) = struct Key.segments x module Tree = struct - type t = { repo : S.repo; tree : S.tree } + type t = { tree : S.tree } let digest t key = match S.Tree.find_tree t.tree (path key) with @@ -183,13 +183,12 @@ module KV_RO (G : Git.S) = struct { t; root } let tree t = - let repo = S.repo t.t in let tree = match S.find_tree t.t t.root with | None -> S.Tree.empty () | Some tree -> tree in - { Tree.repo; tree } + { Tree.tree } let exists t k = Tree.exists (tree t) k let get t k = Tree.get (tree t) k @@ -223,7 +222,7 @@ module KV_RW (G : Irmin_git.G) (C : Mirage_clock.PCLOCK) = struct module Tree = RO.Tree module Info = Irmin_mirage.Info (S.Info) (C) - type batch = { repo : S.repo; mutable tree : S.tree; origin : S.commit } + type batch = { mutable tree : S.tree; origin : S.commit } type store = Batch of batch | Store of RO.t @@ -264,12 +263,10 @@ module KV_RW (G : Irmin_git.G) (C : Mirage_clock.PCLOCK) = struct let t = RO.S.of_commit b.origin in RO.last_modified { root = S.Path.empty; t } key - let repo t = match t.store with Store t -> S.repo t.t | Batch b -> b.repo - let tree t = match t.store with | Store t -> RO.tree t - | Batch b -> { Tree.tree = b.tree; repo = repo t } + | Batch b -> { Tree.tree = b.tree } let digest t k = Lwt_eio.run_eio @@ fun () -> Tree.digest (tree t) k let size t k = Lwt_eio.run_eio @@ fun () -> Tree.size (tree t) k @@ -365,12 +362,11 @@ module KV_RW (G : Irmin_git.G) (C : Mirage_clock.PCLOCK) = struct match t.store with | Batch _ -> Fmt.failwith "No recursive batches" | Store s -> ( - let repo = S.repo s.t in (* get the tree origin *) match get_store_tree s with | None -> Ok (f t) (* no transaction is needed *) | Some (origin, old_tree) -> ( - let batch = { repo; tree = old_tree; origin } in + let batch = { tree = old_tree; origin } in let b = Batch batch in let result = f { t with store = b } in match get_store_tree s with diff --git a/src/irmin-pack/io/gc.ml b/src/irmin-pack/io/gc.ml index e9cd0bda0f..648809b9db 100644 --- a/src/irmin-pack/io/gc.ml +++ b/src/irmin-pack/io/gc.ml @@ -34,16 +34,13 @@ module Make (Args : Gc_args.S) = struct mutable on_finalise : (Stats.Latest_gc.stats, Args.Errs.t) result -> unit; dispatcher : Dispatcher.t; fm : Fm.t; - contents : read Contents_store.t; - node : read Node_store.t; - commit : read Commit_store.t; - mutable partial_stats : Gc_stats_main.t; + partial_stats : Gc_stats_main.t; mutable resulting_stats : Stats.Latest_gc.stats option; latest_gc_target_offset : int63; } - let v ~root ~lower_root ~output ~generation ~unlink ~dispatcher ~fm ~contents - ~node ~commit commit_key = + let v ~root ~lower_root ~output ~generation ~unlink ~dispatcher ~fm + ~contents:_ ~node:_ ~commit:_ commit_key = let open Result_syntax in let new_suffix_start_offset, latest_gc_target_offset = let state : _ Pack_key.state = Pack_key.inspect commit_key in @@ -127,9 +124,6 @@ module Make (Args : Gc_args.S) = struct on_finalise = (fun _ -> ()); dispatcher; fm; - contents; - node; - commit; partial_stats; resulting_stats = None; latest_gc_target_offset; diff --git a/src/irmin-pack/io/sparse_file.ml b/src/irmin-pack/io/sparse_file.ml index d41034ebaa..89d2b42dcf 100644 --- a/src/irmin-pack/io/sparse_file.ml +++ b/src/irmin-pack/io/sparse_file.ml @@ -28,12 +28,7 @@ module Int64_mmap (Io : Io_intf.S) : sig val get : t -> int -> Int64.t val close : t -> (unit, [> Io.close_error ]) result end = struct - type t = { - fn : string; - fd : Io.t; - loaded : bool array; - mutable arr : int64_bigarray; - } + type t = { fd : Io.t; loaded : bool array; arr : int64_bigarray } let sector_size = 512 let length t = BigArr1.dim t.arr @@ -45,7 +40,7 @@ end = struct let size = sz / 8 in let arr = BigArr1.create Bigarray.Int64 Bigarray.c_layout size in let loaded = Array.make (1 + (sz / sector_size)) false in - { fn; fd; arr; loaded } + { fd; arr; loaded } let close t = Io.close t.fd diff --git a/src/irmin-pack/io/store.ml b/src/irmin-pack/io/store.ml index eb3672e0ba..382c6cd8c4 100644 --- a/src/irmin-pack/io/store.ml +++ b/src/irmin-pack/io/store.ml @@ -149,7 +149,6 @@ struct type running_gc = { gc : Gc.t; use_auto_finalisation : bool } type t = { - lru : Lru.t; config : Irmin.Backend.Conf.t; contents : read Contents.CA.t; node : read Node.CA.t; @@ -215,7 +214,6 @@ struct during_batch; running_gc; dispatcher; - lru; lock; } diff --git a/src/irmin-server/unix/server.ml b/src/irmin-server/unix/server.ml index 44d9881863..6ebee01465 100644 --- a/src/irmin-server/unix/server.ml +++ b/src/irmin-server/unix/server.ml @@ -20,7 +20,7 @@ open Lwt.Infix open Irmin_server include Server_intf -let html = [%blob "index.html"] +let html = [%blob "src/irmin-server/unix/index.html"] module Make (Codec : Conn.Codec.S) (Store : Irmin.Generic_key.S) = struct module Command = Command.Make (IO) (Codec) (Store) diff --git a/src/irmin-test/irmin_bench.ml b/src/irmin-test/irmin_bench.ml index 55668da67d..4d37bcc9af 100644 --- a/src/irmin-test/irmin_bench.ml +++ b/src/irmin-test/irmin_bench.ml @@ -18,7 +18,6 @@ open Irmin.Export_for_backends type t = { - root : string; ncommits : int; depth : int; tree_add : int; @@ -93,7 +92,7 @@ let clear = let t = Term.( const (fun () ncommits depth tree_add display clear gc -> - { ncommits; depth; tree_add; display; root = "."; clear; gc }) + { ncommits; depth; tree_add; display; clear; gc }) $ log $ ncommits $ depth @@ -173,7 +172,6 @@ struct let root = "_build/_bench" in let config = config ~root in let size () = size ~root in - let t = { t with root } in Eio_main.run @@ fun _ -> init t config; run t config size diff --git a/src/irmin/lru.ml b/src/irmin/lru.ml index 2ff3cc74aa..4ae221f251 100644 --- a/src/irmin/lru.ml +++ b/src/irmin/lru.ml @@ -78,7 +78,7 @@ module MakeUnsafe (H : Hashtbl.HashedType) = struct type 'a t = { ht : (key * 'a) Q.node HT.t; q : (key * 'a) Q.t; - mutable cap : cap; + cap : cap; mutable w : int; } diff --git a/src/irmin/mem/irmin_mem.ml b/src/irmin/mem/irmin_mem.ml index 95d5a73150..e487c65fbb 100644 --- a/src/irmin/mem/irmin_mem.ml +++ b/src/irmin/mem/irmin_mem.ml @@ -36,9 +36,9 @@ module Read_only (K : Irmin.Type.S) (V : Irmin.Type.S) = struct type key = K.t type value = V.t - type 'a t = { mutable t : value KMap.t; root : string } + type 'a t = { mutable t : value KMap.t } - let new_instance root = { t = KMap.empty; root } + let new_instance _root = { t = KMap.empty } let v = let cache : (string, 'a t) Hashtbl.t = Hashtbl.create 0 in diff --git a/src/irmin/metrics.ml b/src/irmin/metrics.ml index 3e0ab790ea..9ef6fcbd79 100644 --- a/src/irmin/metrics.ml +++ b/src/irmin/metrics.ml @@ -29,6 +29,7 @@ type 'a t = { repr : 'a Repr.ty; state : 'a Atomic.t; } +[@@warning "-unused-field"] let state m = Atomic.get m.state let set_state m v = Atomic.set m.state v diff --git a/test/irmin-client/test.ml b/test/irmin-client/test.ml index 606a9a4110..5607ce2a1a 100644 --- a/test/irmin-client/test.ml +++ b/test/irmin-client/test.ml @@ -18,8 +18,6 @@ open Irmin_client_unix open Util module Info = Info (Client.Info) -let info = Info.v - let () = let style_renderer = `None in Fmt_tty.setup_std_outputs ~style_renderer (); @@ -49,11 +47,6 @@ let error = Alcotest.testable (Fmt.using Error.to_string Fmt.string) (fun a b -> Error.to_string a = Error.to_string b) -let ty t = - Alcotest.testable - (Fmt.using (Irmin.Type.to_string t) Fmt.string) - (fun a b -> Irmin.Type.(unstage (equal t)) a b) - let ping client () = let open Client in let client = client () in diff --git a/test/irmin-pack/test_inode.ml b/test/irmin-pack/test_inode.ml index 026906586d..e7791b0d73 100644 --- a/test/irmin-pack/test_inode.ml +++ b/test/irmin-pack/test_inode.ml @@ -97,7 +97,6 @@ struct struct type t = { store : read Inode.t; - store_contents : read Contents_store.t; fm : File_manager.t; (* Two contents values that are guaranteed to be read by {!store}: *) foo : Key.t; @@ -154,7 +153,7 @@ struct (foo, bar)) in [%log.app "Test context constructed"]; - { store; store_contents; fm; foo; bar } + { store; fm; foo; bar } let close t = File_manager.close t.fm |> Errs.raise_if_error (* closes dict, inodes and contents store. *) From 95b8a5302c3f30e0c59d438f2b2ed019b6730204 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Wed, 6 Mar 2024 10:20:35 +0100 Subject: [PATCH 90/99] macos: reduce number of open files in unix-client test to avoid EMFILE error --- src/irmin-test/irmin_test.mli | 1 + src/irmin-test/store.ml | 4 +-- src/irmin-test/store.mli | 1 + test/irmin-client/test.ml | 56 ++++++++++++++++++++++------------- test/irmin-client/util.ml | 4 ++- 5 files changed, 42 insertions(+), 24 deletions(-) diff --git a/src/irmin-test/irmin_test.mli b/src/irmin-test/irmin_test.mli index 2bb94c2f78..cbdda468e0 100644 --- a/src/irmin-test/irmin_test.mli +++ b/src/irmin-test/irmin_test.mli @@ -63,6 +63,7 @@ val checks : 'a Irmin.Type.t -> string -> 'a list -> 'a list -> unit module Store : sig val run : string -> + ?and_exit:bool -> ?slow:bool -> ?random_seed:int -> sleep:(float -> unit) -> diff --git a/src/irmin-test/store.ml b/src/irmin-test/store.ml index bdb1d768e6..7388caa8f9 100644 --- a/src/irmin-test/store.ml +++ b/src/irmin-test/store.ml @@ -2450,7 +2450,7 @@ let slow_suite (speed, x) = ] (speed, x) -let run name ?(slow = false) ?random_seed ~sleep ~misc tl = +let run name ?and_exit ?(slow = false) ?random_seed ~sleep ~misc tl = let () = match random_seed with | Some x -> Random.init x @@ -2460,4 +2460,4 @@ let run name ?(slow = false) ?random_seed ~sleep ~misc tl = (* Ensure that failures occuring in async lwt threads are raised. *) let tl1 = List.map (suite sleep) tl in let tl1 = if slow then tl1 @ List.map slow_suite tl else tl1 in - Alcotest.run ~bail:true name (misc @ tl1) + Alcotest.run ?and_exit ~bail:true name (misc @ tl1) diff --git a/src/irmin-test/store.mli b/src/irmin-test/store.mli index 5c9635550f..991d933041 100644 --- a/src/irmin-test/store.mli +++ b/src/irmin-test/store.mli @@ -16,6 +16,7 @@ val run : string -> + ?and_exit:bool -> ?slow:bool -> ?random_seed:int -> sleep:(float -> unit) -> diff --git a/test/irmin-client/test.ml b/test/irmin-client/test.ml index 5607ce2a1a..b56484f325 100644 --- a/test/irmin-client/test.ml +++ b/test/irmin-client/test.ml @@ -58,40 +58,54 @@ let ping client () = let misc client = [ ("ping", `Quick, ping client) ] let misc client = [ ("misc", misc client) ] -let main ~env () = - let clock = Eio.Stdenv.clock env in +let unix_suite ~env () = Eio.Switch.run @@ fun sw -> + let clock = Eio.Stdenv.clock env in let kind, uri = run_server ~sw ~clock `Unix_domain in - let config = Irmin_client_unix.config uri in - let client = Client.Repo.v config in - let client () = Lwt_eio.run_lwt @@ fun () -> Client.dup client in let module Unix_socket = Make (struct let uri = uri let kind = kind end) in + let tests = Unix_socket.suite () in + let config = Irmin_client_unix.config uri in + let client = Client.Repo.v config in + let client () = Lwt_eio.run_lwt @@ fun () -> Client.dup client in + Irmin_test.Store.run "irmin-server.unix" ~and_exit:false ~sleep:Eio_unix.sleep + ~misc:(misc client) + [ (`Quick, tests) ] + +let tcp_suite ~env () = + Eio.Switch.run @@ fun sw -> + let clock = Eio.Stdenv.clock env in let module Tcp_socket = Make (struct let kind, uri = run_server ~sw ~clock `Tcp end) in + let tests = Tcp_socket.suite () in + Irmin_test.Store.run "irmin-server.tcp" ~and_exit:false ~sleep:Eio_unix.sleep + ~misc:[] + [ (`Quick, tests) ] + +let websocket_suite ~env () = + Eio.Switch.run @@ fun sw -> + let clock = Eio.Stdenv.clock env in let module Websocket = Make (struct let kind, uri = run_server ~sw ~clock `Websocket end) in - let slow = Sys.getenv_opt "SLOW" |> Option.is_some in - let only = Sys.getenv_opt "ONLY" in - let tests = - match only with - | Some "ws" -> [ (`Quick, Websocket.suite ()) ] - | Some "tcp" -> [ (`Quick, Tcp_socket.suite ()) ] - | Some "unix" -> [ (`Quick, Unix_socket.suite ()) ] - | Some s -> failwith ("Invalid selection: " ^ s) - | None -> - [ - (`Quick, Tcp_socket.suite ()); - (`Quick, Unix_socket.suite ()); - (`Quick, Websocket.suite ()); - ] + let tests = Websocket.suite () in + Irmin_test.Store.run "irmin-server.ws" ~and_exit:false ~sleep:Eio_unix.sleep + ~misc:[] + [ (`Quick, tests) ] + +let main ~env () = + let suites = + [ ("tcp", tcp_suite); ("unix", unix_suite); ("ws", websocket_suite) ] in - Irmin_test.Store.run "irmin-server" ~sleep:Eio_unix.sleep ~slow - ~misc:(misc client) tests + match Sys.getenv_opt "ONLY" with + | None -> List.iter (fun (_, suite) -> suite ~env ()) suites + | Some suite_name -> ( + match List.assoc_opt suite_name suites with + | Some suite -> suite ~env () + | None -> failwith ("Invalid selection: " ^ suite_name)) let () = Eio_main.run @@ fun env -> diff --git a/test/irmin-client/util.ml b/test/irmin-client/util.ml index 466beb1b7c..ffe32da1d1 100644 --- a/test/irmin-client/util.ml +++ b/test/irmin-client/util.ml @@ -33,11 +33,13 @@ let run_server ~sw ~clock s = ("Unix_domain", Uri.of_string ("unix://" ^ sock)) | `Tcp -> ("Tcp", Uri.of_string "tcp://localhost:90992") in + let stop, set_stop = Lwt.wait () in + Eio.Switch.on_release sw (fun () -> Lwt.wakeup_later set_stop ()); Eio.Fiber.fork_daemon ~sw (fun () -> let () = Irmin.Backend.Watch.set_listen_dir_hook Irmin_watcher.hook in let key = Irmin.Backend.Conf.root Irmin_mem.Conf.spec in let conf = Irmin.Backend.Conf.singleton Irmin_mem.Conf.spec key kind in - Lwt_eio.run_lwt (fun () -> Server.v ~uri conf >>= Server.serve); + Lwt_eio.run_lwt (fun () -> Server.v ~uri conf >>= Server.serve ~stop); `Stop_daemon); Eio.Time.sleep clock 0.1; (kind, uri) From 5905ef5b110b0d5e5ca9ef4d3cf0894603e1ee52 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Wed, 6 Mar 2024 12:05:13 +0100 Subject: [PATCH 91/99] libirmin: fix compilation on ppc64 --- src/libirmin/lib/dune | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/src/libirmin/lib/dune b/src/libirmin/lib/dune index a844945ed7..5664d7a29b 100644 --- a/src/libirmin/lib/dune +++ b/src/libirmin/lib/dune @@ -7,22 +7,18 @@ (executable (name libirmin) - (package libirmin) - (public_name libirmin) (libraries libirmin_bindings) - (modes - (native shared_object) - native) + (modes shared_object) (modules libirmin irmin_bindings) (foreign_stubs (language c) (names irmin)) (flags - (-w -unused-var-strict -ccopt "-Wl,-znow"))) + (:standard -w -unused-var-strict -ccopt "-Wl,-znow"))) (install (package libirmin) (section lib) (files (irmin.h as include/irmin.h) - (libirmin.so as lib/libirmin.so))) + (libirmin%{ext_dll} as lib/libirm%{ext_dll}))) From 883c7063b4e26b08ea4d91f8de76f7d6f5600986 Mon Sep 17 00:00:00 2001 From: gwenaelle Date: Thu, 1 Feb 2024 15:00:27 +0100 Subject: [PATCH 92/99] Upgrade CI coverage to OCaml 5.1.x --- .github/workflows/coverage.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/coverage.yml b/.github/workflows/coverage.yml index 3f888004e9..69194a46cc 100644 --- a/.github/workflows/coverage.yml +++ b/.github/workflows/coverage.yml @@ -19,7 +19,7 @@ jobs: - ubuntu-latest packages: [ '.' ] ocaml-compiler: - - 4.13.x + - 5.1.x runs-on: ${{ matrix.os }} From 8601dce9c942f9f131bc2b1968e14301394d182e Mon Sep 17 00:00:00 2001 From: ArthurW Date: Tue, 26 Mar 2024 19:32:38 +0100 Subject: [PATCH 93/99] Upgrade to Eio 1.0 --- irmin-cli.opam | 2 +- irmin-fs.opam | 2 +- irmin-pack.opam | 2 +- irmin-server.opam | 2 +- irmin-test.opam | 2 +- irmin.opam | 5 ++--- libirmin.opam | 2 +- 7 files changed, 8 insertions(+), 9 deletions(-) diff --git a/irmin-cli.opam b/irmin-cli.opam index 9605496d22..6a798562e2 100644 --- a/irmin-cli.opam +++ b/irmin-cli.opam @@ -46,7 +46,7 @@ depends: [ "fmt" "git" {>= "3.7.0"} "happy-eyeballs-lwt" - "eio_main" {>= "0.12"} + "eio_main" {>= "1.0"} "lwt_eio" {>= "0.5"} "lwt" {>= "5.3.0"} "irmin-test" {with-test & = version} diff --git a/irmin-fs.opam b/irmin-fs.opam index 1461afb86e..8cc535640c 100644 --- a/irmin-fs.opam +++ b/irmin-fs.opam @@ -19,7 +19,7 @@ depends: [ "irmin" {= version} "astring" "logs" - "eio" {>= "0.15"} + "eio" {>= "1.0"} "lwt" {>= "5.3.0"} "alcotest" {with-test} "irmin-test" {with-test & = version} diff --git a/irmin-pack.opam b/irmin-pack.opam index c92fda6ec4..a7af890189 100644 --- a/irmin-pack.opam +++ b/irmin-pack.opam @@ -20,7 +20,7 @@ depends: [ "index" {= "dev"} "fmt" "logs" - "eio" {>= "0.15"} + "eio" {>= "1.0"} "mtime" {>= "2.0.0"} "cmdliner" "optint" {>= "0.1.0"} diff --git a/irmin-server.opam b/irmin-server.opam index 16eac0106a..5df0018e93 100644 --- a/irmin-server.opam +++ b/irmin-server.opam @@ -18,7 +18,7 @@ depends: [ "fmt" "cmdliner" {>= "1.0.4"} "logs" {>= "0.7.0"} - "eio_main" {>= "0.15"} + "eio_main" {>= "1.0"} "lwt_eio" {>= "0.5.1"} "lwt" {>= "5.4.0"} "conduit-lwt-unix" {>= "6.0.0"} diff --git a/irmin-test.opam b/irmin-test.opam index 3248aa8067..7955c7b3e4 100644 --- a/irmin-test.opam +++ b/irmin-test.opam @@ -23,7 +23,7 @@ depends: [ "jsonm" "logs" "lwt" {>= "5.3.0"} - "eio" {>= "0.15"} + "eio" {>= "1.0"} "eio_main" {>= "0.15"} "alcotest" {>= "dev"} "qcheck-alcotest" {with-test & >= "0.21.1"} diff --git a/irmin.opam b/irmin.opam index 69efbea17f..5619596f81 100644 --- a/irmin.opam +++ b/irmin.opam @@ -21,7 +21,7 @@ depends: [ "uri" {>= "1.3.12"} "uutf" "jsonm" {>= "1.0.0"} - "eio" {>= "0.15"} + "eio" {>= "1.0"} "lwt" {>= "5.6.1"} "digestif" {>= "0.9.0"} "ocamlgraph" @@ -31,10 +31,9 @@ depends: [ "mtime" {>= "2.0.0"} "bigstringaf" { >= "0.2.0" } "ppx_irmin" {= version} - "eio_main" {>= "0.15" & with-test} + "eio_main" {>= "1.0" & with-test} "hex" {with-test} "alcotest" {= "dev" & with-test} - "eio_main" {>= "0.5" & with-test} "qcheck-alcotest" {with-test} "vector" {with-test} "odoc" {(< "2.0.1" | > "2.0.2") & with-doc} # See https://github.com/ocaml/odoc/issues/793 diff --git a/libirmin.opam b/libirmin.opam index 8623f68cd3..9eac98421c 100644 --- a/libirmin.opam +++ b/libirmin.opam @@ -12,7 +12,7 @@ depends: [ "ctypes-foreign" {>= "0.18"} "irmin" {= version} "irmin-cli" {= version} - "eio_main" {>= "0.12"} + "eio_main" {>= "1.0"} "lwt_eio" {>= "0.5"} ] build: [ From 3fb0a996e064c98d945e40921d26f4e4720ce910 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Tue, 9 Apr 2024 15:23:20 +0200 Subject: [PATCH 94/99] Update CHANGES --- CHANGES.md | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index dba9822bb3..db8c8e1d13 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,9 @@ +## 4.0.0 + +### Changed + +- Convert to direct-style with Eio (#2149, @patricoferris, @ElectreAAS, @clecat, @art-w) + ## 3.9.0 (2023-10-05) ### Added From a8263db19d2400f8d905c2dea6d71cabd2eec565 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Fri, 12 Apr 2024 14:24:07 +0200 Subject: [PATCH 95/99] Temporarily disable CI for specific platforms issues --- .github/workflows/coverage.yml | 26 +++++--------------------- bench.Dockerfile | 11 +++++++++++ examples/dune | 13 ++++++++++++- examples/merkle_proofs.md | 2 +- src/irmin-pack/io/store.ml | 5 +---- src/libirmin/lib/dune | 8 ++++++-- test/irmin-client/dune | 7 ++++++- test/irmin-pack/dune | 7 ++++++- test/irmin-tezos/dune | 6 +++++- test/libirmin/dune | 4 +++- 10 files changed, 56 insertions(+), 33 deletions(-) create mode 100644 bench.Dockerfile diff --git a/.github/workflows/coverage.yml b/.github/workflows/coverage.yml index 69194a46cc..97e750708b 100644 --- a/.github/workflows/coverage.yml +++ b/.github/workflows/coverage.yml @@ -17,7 +17,6 @@ jobs: matrix: os: - ubuntu-latest - packages: [ '.' ] ocaml-compiler: - 5.1.x @@ -30,33 +29,18 @@ jobs: git config --global core.eol lf - name: Checkout code - uses: actions/checkout@v2 + uses: actions/checkout@v4 - name: Use OCaml ${{ matrix.ocaml-compiler }} uses: ocaml/setup-ocaml@v2 with: ocaml-compiler: ${{ matrix.ocaml-compiler }} - opam-local-packages: $${ matrix.opam-local-packages }} - opam-depext-flags: --with-test - - - name: Pin local packages - run: | - # Pin all local opam files to avoid internal conflicts - # - # TODO: replace with `opam pin --with-version` when Opam 2.1 is - # available via `setup-ocaml`. - find . -maxdepth 1 -name '*.opam' -printf '%P\n' |\ - cut -d. -f1 |\ - xargs -I{} -n 1 opam pin add {}.dev ./ -n - - - name: Install depexts - run: | - find . -maxdepth 1 -name '*.opam' -printf '%P\n' |\ - cut -d. -f1 |\ - xargs opam depext --update -y - name: Install Opam dependencies - run: opam install ${{ matrix.packages }} --with-test --deps-only + run: opam install . --with-test --deps-only + + - name: Build + run: opam exec -- dune build - name: Run tests with coverage instrumentation run: opam exec -- dune runtest --instrument-with bisect_ppx diff --git a/bench.Dockerfile b/bench.Dockerfile new file mode 100644 index 0000000000..1245344c24 --- /dev/null +++ b/bench.Dockerfile @@ -0,0 +1,11 @@ +FROM ocaml/opam:debian-ocaml-5.1 +RUN sudo ln -sf /usr/bin/opam-2.1 /usr/bin/opam +RUN mkdir bench-dir && chown opam:opam bench-dir +WORKDIR bench-dir +RUN sudo chown opam . +COPY *.opam ./ +RUN opam remote add origin https://github.com/ocaml/opam-repository.git && opam update +RUN opam pin -yn --with-version=dev . +RUN opam install -y --deps-only --with-test . +COPY . ./ +ENTRYPOINT opam exec -- make bench diff --git a/examples/dune b/examples/dune index 28f453fd47..60ceb8923f 100644 --- a/examples/dune +++ b/examples/dune @@ -62,4 +62,15 @@ (mdx (files merkle_proofs.md) - (libraries irmin irmin-cli irmin-git.unix ppx_irmin)) + (deps %{bin:irmin}) + (libraries + irmin + irmin-cli + irmin-git + irmin-git.unix + eio + eio_main + eio.unix + lwt_eio) + (enabled_if + (<> %{model} "ppc64le"))) diff --git a/examples/merkle_proofs.md b/examples/merkle_proofs.md index 5c6c600050..3ef39aefdf 100644 --- a/examples/merkle_proofs.md +++ b/examples/merkle_proofs.md @@ -7,12 +7,12 @@ More specifically, for Irmin, a Merkle proof is the subset of a tree stored in a ### Setting up a Bank ```ocaml +# #require "eio_main";; # #require "digestif.ocaml";; # #require "checkseum.ocaml";; # #require "irmin";; # #require "irmin-git.unix";; # #require "ppx_irmin";; -# #require "eio_main";; ``` First, create an irmin-unix store module which uses `int` as contents. diff --git a/src/irmin-pack/io/store.ml b/src/irmin-pack/io/store.ml index 382c6cd8c4..bef47fe962 100644 --- a/src/irmin-pack/io/store.ml +++ b/src/irmin-pack/io/store.ml @@ -293,9 +293,7 @@ struct | Some { gc; _ } -> if Atomic.get t.during_batch then Error `Gc_forbidden_during_batch - else - Eio.Mutex.use_rw ~protect:false t.lock @@ fun () -> - Gc.finalise ~wait gc + else Gc.finalise ~wait gc in match result with | Ok (`Finalised _ as x) -> @@ -319,7 +317,6 @@ struct match Atomic.get t.running_gc with | None | Some { use_auto_finalisation = false; _ } -> () | Some { use_auto_finalisation = true; _ } -> - Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> let _ = finalise_exn ~wait:false t in () diff --git a/src/libirmin/lib/dune b/src/libirmin/lib/dune index 5664d7a29b..be7d224bbf 100644 --- a/src/libirmin/lib/dune +++ b/src/libirmin/lib/dune @@ -14,11 +14,15 @@ (language c) (names irmin)) (flags - (:standard -w -unused-var-strict -ccopt "-Wl,-znow"))) + (:standard -w -unused-var-strict -ccopt "-Wl,-znow")) + (enabled_if + (<> %{ocaml_version} 5.2.0~alpha1))) (install (package libirmin) (section lib) (files (irmin.h as include/irmin.h) - (libirmin%{ext_dll} as lib/libirm%{ext_dll}))) + (libirmin%{ext_dll} as lib/libirm%{ext_dll})) + (enabled_if + (<> %{ocaml_version} 5.2.0~alpha1))) diff --git a/test/irmin-client/dune b/test/irmin-client/dune index e373485974..c2c06c6e16 100644 --- a/test/irmin-client/dune +++ b/test/irmin-client/dune @@ -8,4 +8,9 @@ websocket-lwt-unix conduit-lwt-unix irmin-test - irmin-watcher)) + irmin-watcher) + ; TODO: fix unix EMFILE error + (enabled_if + (and + (<> %{system} macosx) + (<> %{system} freebsd)))) diff --git a/test/irmin-pack/dune b/test/irmin-pack/dune index 6b3f916339..87d5e3f31c 100644 --- a/test/irmin-pack/dune +++ b/test/irmin-pack/dune @@ -48,7 +48,12 @@ ;; Attached to `irmin-tezos` to avoid a cyclic dependency with `irmin-pack` (package irmin-tezos) (action - (run ./test.exe -q --color=always))) + (run ./test.exe -q --color=always)) + ; TODO: Fix unix waitpid error in irmin-pack GC + (enabled_if + (and + (<> %{system} macosx) + (<> %{system} freebsd)))) (library (name common) diff --git a/test/irmin-tezos/dune b/test/irmin-tezos/dune index e716cc75ef..1709b11f27 100644 --- a/test/irmin-tezos/dune +++ b/test/irmin-tezos/dune @@ -19,7 +19,11 @@ (deps (file irmin_fsck.exe) (file data) - (alias generate-cli-test-data))) + (alias generate-cli-test-data)) + (enabled_if + (and + (<> %{system} macosx) + (<> %{system} freebsd)))) ;FIXME: we should not depend on the version of cmdliner ;(rule diff --git a/test/libirmin/dune b/test/libirmin/dune index d71a6fa782..e6f9299041 100644 --- a/test/libirmin/dune +++ b/test/libirmin/dune @@ -8,7 +8,9 @@ (setenv LD_LIBRARY_PATH ../../src/libirmin/lib - (run ./test.exe))))) + (run ./test.exe)))) + (enabled_if + (<> %{ocaml_version} 5.2.0~alpha1))) (rule (targets test.exe) From 66c61443fdc44ca7d6541e5f5d70c89b3d567f54 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Mon, 6 May 2024 18:54:39 +0200 Subject: [PATCH 96/99] Update opam for OCaml 5.1.0 --- irmin-chunk.opam | 2 +- irmin-cli.opam | 2 +- irmin-client.opam | 2 +- irmin-containers.opam | 2 +- irmin-fs.opam | 2 +- irmin-git.opam | 2 +- irmin-graphql.opam | 2 +- irmin-http.opam | 2 +- irmin-pack-tools.opam | 2 +- irmin-pack.opam | 2 +- irmin-server.opam | 2 +- irmin-test.opam | 2 +- irmin.opam | 2 +- 13 files changed, 13 insertions(+), 13 deletions(-) diff --git a/irmin-chunk.opam b/irmin-chunk.opam index 756ec81ad0..887190cfa5 100644 --- a/irmin-chunk.opam +++ b/irmin-chunk.opam @@ -13,7 +13,7 @@ build: [ ] depends: [ - "ocaml" {>= "4.02.3"} + "ocaml" {>= "5.1.0"} "dune" {>= "3.5.0"} "irmin" {= version} "fmt" diff --git a/irmin-cli.opam b/irmin-cli.opam index 6a798562e2..b469c698bf 100644 --- a/irmin-cli.opam +++ b/irmin-cli.opam @@ -16,7 +16,7 @@ build: [ available: arch != "arm32" & arch != "x86_32" depends: [ - "ocaml" {>= "4.01.0"} + "ocaml" {>= "5.1.0"} "dune" {>= "3.5.0"} "irmin" {= version} "irmin-git" {= version} diff --git a/irmin-client.opam b/irmin-client.opam index 696e617c27..77ac627658 100644 --- a/irmin-client.opam +++ b/irmin-client.opam @@ -8,7 +8,7 @@ doc: "https://irmin.org" dev-repo: "git+ssh://github.com/mirage/irmin" bug-reports: "https://github.com/mirage/irmin/issues" depends: [ - "ocaml" {>= "4.08.0"} + "ocaml" {>= "5.1.0"} "dune" {>= "3.5.0"} "irmin-server" {= version} "irmin-cli" {= version} diff --git a/irmin-containers.opam b/irmin-containers.opam index 500d4d5b15..088baf7a56 100644 --- a/irmin-containers.opam +++ b/irmin-containers.opam @@ -14,7 +14,7 @@ build: [ ] depends: [ - "ocaml" {>= "4.03.0"} + "ocaml" {>= "5.1.0"} "dune" {>= "3.5.0"} "irmin" {= version} "irmin-fs" {= version} diff --git a/irmin-fs.opam b/irmin-fs.opam index 8cc535640c..900563fff4 100644 --- a/irmin-fs.opam +++ b/irmin-fs.opam @@ -14,7 +14,7 @@ build: [ ] depends: [ - "ocaml" {>= "4.03.0"} + "ocaml" {>= "5.1.0"} "dune" {>= "3.5.0"} "irmin" {= version} "astring" diff --git a/irmin-git.opam b/irmin-git.opam index 6f0f202c22..1fef98b12f 100644 --- a/irmin-git.opam +++ b/irmin-git.opam @@ -15,7 +15,7 @@ build: [ ] depends: [ - "ocaml" {>= "4.02.3"} + "ocaml" {>= "5.1.0"} "dune" {>= "3.5.0"} "irmin" {= version} "ppx_irmin" {= version} diff --git a/irmin-graphql.opam b/irmin-graphql.opam index 7b1533bf46..2b61f77202 100644 --- a/irmin-graphql.opam +++ b/irmin-graphql.opam @@ -14,7 +14,7 @@ build: [ ] depends: [ - "ocaml" {>= "4.03.0"} + "ocaml" {>= "5.1.0"} "dune" {>= "3.5.0"} "irmin" {= version} "graphql" {>= "0.14.0"} diff --git a/irmin-http.opam b/irmin-http.opam index 541cda4805..47edc91aff 100644 --- a/irmin-http.opam +++ b/irmin-http.opam @@ -14,7 +14,7 @@ build: [ ] depends: [ - "ocaml" {>= "4.02.3"} + "ocaml" {>= "5.1.0"} "dune" {>= "3.5.0"} "crunch" {>= "2.2.0"} "webmachine" {>= "0.6.0"} diff --git a/irmin-pack-tools.opam b/irmin-pack-tools.opam index 1589e1f5a8..ff059d2829 100644 --- a/irmin-pack-tools.opam +++ b/irmin-pack-tools.opam @@ -16,7 +16,7 @@ build: [ available: arch != "arm32" & arch != "x86_32" depends: [ - "ocaml" {>= "4.01.0"} + "ocaml" {>= "5.1.0"} "dune" {>= "3.5.0"} "irmin-tezos" {= version} "irmin-pack" {= version} diff --git a/irmin-pack.opam b/irmin-pack.opam index a7af890189..9d580c6144 100644 --- a/irmin-pack.opam +++ b/irmin-pack.opam @@ -13,7 +13,7 @@ build: [ ] depends: [ - "ocaml" {>= "4.12.0"} + "ocaml" {>= "5.1.0"} "dune" {>= "3.5.0"} "irmin" {= version} "ppx_irmin" {= version} diff --git a/irmin-server.opam b/irmin-server.opam index 5df0018e93..6c2d21674c 100644 --- a/irmin-server.opam +++ b/irmin-server.opam @@ -8,7 +8,7 @@ doc: "https://irmin.org" dev-repo: "git+ssh://github.com/mirage/irmin" bug-reports: "https://github.com/mirage/irmin/issues" depends: [ - "ocaml" {>= "4.08.0"} + "ocaml" {>= "5.1.0"} "dune" {>= "3.5.0"} "optint" {>= "0.1.0"} "irmin" {= version} diff --git a/irmin-test.opam b/irmin-test.opam index 7955c7b3e4..994e735074 100644 --- a/irmin-test.opam +++ b/irmin-test.opam @@ -15,7 +15,7 @@ build: [ depends: [ "irmin" {= version} "ppx_irmin" {= version} - "ocaml" {>= "4.02.3"} + "ocaml" {>= "5.1.0"} "dune" {>= "3.5.0"} "mtime" {>= "2.0.0"} "astring" diff --git a/irmin.opam b/irmin.opam index 5619596f81..73da72ab39 100644 --- a/irmin.opam +++ b/irmin.opam @@ -14,7 +14,7 @@ build: [ ] depends: [ - "ocaml" {>= "4.08.0"} + "ocaml" {>= "5.1.0"} "dune" {>= "3.5.0"} "repr" {>= "0.6.0"} "fmt" {>= "0.8.5"} From 49e21c16988afd6fd00f6e26e969c9ccc84d430c Mon Sep 17 00:00:00 2001 From: ArthurW Date: Tue, 25 Jun 2024 13:22:43 +0200 Subject: [PATCH 97/99] Update CI for OCaml 5.2 --- .ocamlformat | 2 +- src/libirmin/lib/dune | 8 ++------ test/libirmin/dune | 2 +- 3 files changed, 4 insertions(+), 8 deletions(-) diff --git a/.ocamlformat b/.ocamlformat index 4904e7748d..1e05915f71 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version = 0.26.1 +version = 0.26.2 profile = conventional ocaml-version = 4.08.0 diff --git a/src/libirmin/lib/dune b/src/libirmin/lib/dune index be7d224bbf..5664d7a29b 100644 --- a/src/libirmin/lib/dune +++ b/src/libirmin/lib/dune @@ -14,15 +14,11 @@ (language c) (names irmin)) (flags - (:standard -w -unused-var-strict -ccopt "-Wl,-znow")) - (enabled_if - (<> %{ocaml_version} 5.2.0~alpha1))) + (:standard -w -unused-var-strict -ccopt "-Wl,-znow"))) (install (package libirmin) (section lib) (files (irmin.h as include/irmin.h) - (libirmin%{ext_dll} as lib/libirm%{ext_dll})) - (enabled_if - (<> %{ocaml_version} 5.2.0~alpha1))) + (libirmin%{ext_dll} as lib/libirm%{ext_dll}))) diff --git a/test/libirmin/dune b/test/libirmin/dune index e6f9299041..fdc5086692 100644 --- a/test/libirmin/dune +++ b/test/libirmin/dune @@ -10,7 +10,7 @@ ../../src/libirmin/lib (run ./test.exe)))) (enabled_if - (<> %{ocaml_version} 5.2.0~alpha1))) + (<> %{model} "ppc64le"))) (rule (targets test.exe) From 7186af2b0bbd1e7250b687277a4ac2865a133507 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Tue, 25 Jun 2024 14:22:23 +0200 Subject: [PATCH 98/99] Fix multicore race in unit test --- test/irmin-pack/test_multicore.ml | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/test/irmin-pack/test_multicore.ml b/test/irmin-pack/test_multicore.ml index a93518bd00..a3ae257712 100644 --- a/test/irmin-pack/test_multicore.ml +++ b/test/irmin-pack/test_multicore.ml @@ -243,8 +243,15 @@ let check_patch_was_applied patch tree = List.iter (function | `Add (name, contents) -> - assert (Store.Tree.find tree name = Some contents) - | `Remove name -> assert (not (Store.Tree.mem tree name))) + if not (Store.Tree.find tree name = Some contents) then + failwith + (Printf.sprintf "Add %S failed" + (Repr.to_string Store.path_t name)) + | `Remove name -> + if Store.Tree.mem tree name then + failwith + (Printf.sprintf "Remove %S failed" + (Repr.to_string Store.path_t name))) patch let test_commit d_mgr = @@ -257,9 +264,9 @@ let test_commit d_mgr = let do_commit patch () = List.iter (fun op -> - let tree = Store.Head.get store |> Store.Commit.tree in - let tree = apply_op tree op in - Store.set_tree_exn ~info store [] tree) + Store.with_tree_exn ~strategy:`Merge ~info store [] (function + | None -> assert false + | Some tree -> Some (apply_op tree op))) patch; let tree = Store.main repo |> Store.Head.get |> Store.Commit.tree in check_patch_was_applied patch tree From aed087e264484680ee2e899628f165f6c49c3026 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Mon, 22 Jul 2024 11:27:27 +0200 Subject: [PATCH 99/99] Fix Codecov CI: add secret token, disable on PRs --- .github/workflows/coverage.yml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/.github/workflows/coverage.yml b/.github/workflows/coverage.yml index 97e750708b..5b2601608a 100644 --- a/.github/workflows/coverage.yml +++ b/.github/workflows/coverage.yml @@ -4,7 +4,6 @@ on: push: branches: - main - pull_request: schedule: # Prime the caches every Monday - cron: 0 1 * * MON @@ -30,6 +29,8 @@ jobs: - name: Checkout code uses: actions/checkout@v4 + with: + fetch-depth: 0 - name: Use OCaml ${{ matrix.ocaml-compiler }} uses: ocaml/setup-ocaml@v2 @@ -46,6 +47,7 @@ jobs: run: opam exec -- dune runtest --instrument-with bisect_ppx - name: Send coverage report to Codecov - run: opam exec -- bisect-ppx-report send-to Codecov + run: opam exec -- bisect-ppx-report send-to Codecov --verbose env: + CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }} PULL_REQUEST_NUMBER: ${{ github.event.number }}