Fix multicore race in unit test

mirage · Jun 25, 2024 · 7186af2 · 7186af2
1 parent 49e21c1
commit 7186af2
Showing 1 changed file with 12 additions and 5 deletions.
diff --git 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