fix: patch back fail on promotions

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>

Author: rgrinberg

src/dune_engine/sandbox.ml

@@ -225,41 +225,67 @@ let register_snapshot_promotion t (targets : Targets.Validated.t) ~old_snapshot
   let in_source_tree p =
     Path.extract_build_context_dir_maybe_sandboxed p |> Option.value_exn |> snd
   in
-  let copy_file p =
-    let source_file = in_source_tree p in
-    let correction_file = Path.as_in_build_dir_exn p in
-    Diff_promotion.register_intermediate `Move ~source_file ~correction_file
-  in
-  let delete what file = in_source_tree file |> Diff_promotion.register_delete what in
+  let diffs = ref [] in
+  let add_copy_file p = diffs := p :: !diffs in
+  let deletes = ref [] in
+  let add_delete what file = deletes := (what, in_source_tree file) :: !deletes in
   let target_root_in_sandbox = map_path t targets.root in
-  Path.Map.iter2 old_snapshot new_snapshot ~f:(fun p before after ->
-    if
-      not
-        (let dir = Path.as_in_build_dir_exn (Path.parent_exn p) in
-         Path.Build.equal dir target_root_in_sandbox
-         &&
-         let basename = Path.basename p in
-         Filename.Set.mem targets.files basename || Filename.Set.mem targets.dirs basename)
-    then (
-      match before, after with
-      | None, None -> assert false
-      | None, Some (`File _) -> copy_file p
-      | Some (`File _), None -> delete `File p
-      | Some `Dir, None -> delete `Directory p
-      | Some `Dir, Some `Dir -> ()
-      | None, Some `Dir ->
-        (* We don't create empty dirs and rely on the traversal of this dir to
+  let () =
+    Path.Map.iter2 old_snapshot new_snapshot ~f:(fun p before after ->
+      if
+        not
+          (let dir = Path.as_in_build_dir_exn (Path.parent_exn p) in
+           Path.Build.equal dir target_root_in_sandbox
+           &&
+           let basename = Path.basename p in
+           Filename.Set.mem targets.files basename
+           || Filename.Set.mem targets.dirs basename)
+      then (
+        match before, after with
+        | None, None -> assert false
+        | None, Some (`File _) -> add_copy_file p
+        | Some (`File _), None -> add_delete `File p
+        | Some `Dir, None -> add_delete `Directory p
+        | Some `Dir, Some `Dir -> ()
+        | None, Some `Dir ->
+          (* We don't create empty dirs and rely on the traversal of this dir to
            create the underlying files. Mayb e we should try harder *)
-        ()
-      | Some (`File _), Some `Dir ->
-        (* We are going to traverse the target directory here, but we should
+          ()
+        | Some (`File _), Some `Dir ->
+          (* We are going to traverse the target directory here, but we should
            really treat this as a deletion *)
-        ()
-      | Some `Dir, Some (`File _) -> copy_file p
-      | Some (`File before), Some (`File after) ->
-        (match Cached_digest.Reduced_stats.compare before after with
-         | Eq -> ()
-         | Lt | Gt -> copy_file p)))
+          ()
+        | Some `Dir, Some (`File _) -> add_copy_file p
+        | Some (`File before), Some (`File after) ->
+          (match Cached_digest.Reduced_stats.compare before after with
+           | Eq -> ()
+           | Lt | Gt -> add_copy_file p)))
+  in
+  Fiber.fork_and_join_unit
+    (fun () ->
+       Fiber.parallel_iter !diffs ~f:(fun path ->
+         let source = Path.drop_optional_sandbox_root path in
+         Diff_action.exec
+           t.loc
+           { Dune_util.Action.Diff.file1 = source
+           ; file2 = Path.as_in_build_dir_exn path
+           ; optional = true
+           ; mode = Text
+           }))
+    (fun () ->
+       Fiber.parallel_iter !deletes ~f:(fun (what, path) ->
+         Diff_promotion.register_delete what path;
+         let what =
+           match what with
+           | `File -> "File"
+           | `Directory -> "Directory"
+         in
+         User_error.raise
+           [ Pp.textf
+               "%s %s should be deleted"
+               what
+               (Path.Source.to_string_maybe_quoted path)
+           ]))
 ;;
 
 let hint_delete_dir =
@@ -273,42 +299,46 @@ let move_targets_to_build_dir t ~should_be_skipped ~(targets : Targets.Validated
   : unit Fiber.t
   =
   let open Fiber.O in
-  let+ start, stop, queued =
-    maybe_async (fun () ->
-      Option.iter t.snapshot ~f:(fun old_snapshot ->
-        register_snapshot_promotion t targets ~old_snapshot);
-      Targets.Validated.iter
-        targets
-        ~file:(fun target ->
-          if not (should_be_skipped target)
-          then rename_optional_file ~src:(map_path t target) ~dst:target)
-        ~dir:(fun target ->
-          let src_dir = map_path t target in
-          (match Path.Untracked.stat (Path.build target) with
-           | Error (Unix.ENOENT, _, _) -> ()
-           | Error e ->
-             User_error.raise
-               ~hints:hint_delete_dir
-               [ Pp.textf "unable to stat %s" (Path.Build.to_string_maybe_quoted target)
-               ; Pp.text "reason:"
-               ; Pp.text (Unix_error.Detailed.to_string_hum e)
-               ]
-           | Ok { Unix.st_kind; _ } ->
-             (* We clean up all targets (including directory targets) before
+  let start = Time.now () in
+  let+ () =
+    match t.snapshot with
+    | None -> Fiber.return ()
+    | Some old_snapshot -> register_snapshot_promotion t targets ~old_snapshot
+  in
+  let () =
+    Targets.Validated.iter
+      targets
+      ~file:(fun target ->
+        if not (should_be_skipped target)
+        then rename_optional_file ~src:(map_path t target) ~dst:target)
+      ~dir:(fun target ->
+        let src_dir = map_path t target in
+        (match Path.Untracked.stat (Path.build target) with
+         | Error (Unix.ENOENT, _, _) -> ()
+         | Error e ->
+           User_error.raise
+             ~hints:hint_delete_dir
+             [ Pp.textf "unable to stat %s" (Path.Build.to_string_maybe_quoted target)
+             ; Pp.text "reason:"
+             ; Pp.text (Unix_error.Detailed.to_string_hum e)
+             ]
+         | Ok { Unix.st_kind; _ } ->
+           (* We clean up all targets (including directory targets) before
               running an action, so this branch should be unreachable unless
               the rule somehow escaped the sandbox *)
-             User_error.raise
-               ~hints:hint_delete_dir
-               [ Pp.textf
-                   "Target %s of kind %S already exists in the build directory"
-                   (Path.Build.to_string_maybe_quoted target)
-                   (File_kind.to_string_hum st_kind)
-               ]);
-          if Fpath.exists (Path.Build.to_string src_dir)
-          then Unix.rename (Path.Build.to_string src_dir) (Path.Build.to_string target)))
+           User_error.raise
+             ~hints:hint_delete_dir
+             [ Pp.textf
+                 "Target %s of kind %S already exists in the build directory"
+                 (Path.Build.to_string_maybe_quoted target)
+                 (File_kind.to_string_hum st_kind)
+             ]);
+        if Fpath.exists (Path.Build.to_string src_dir)
+        then Unix.rename (Path.Build.to_string src_dir) (Path.Build.to_string target))
   in
+  let stop = Time.now () in
   Dune_trace.emit ~buffered:true Sandbox (fun () ->
-    Dune_trace.Event.sandbox `Extract ~start ~stop ~queued t.loc ~dir:t.dir)
+    Dune_trace.Event.sandbox `Extract ~start ~stop ~queued:None t.loc ~dir:t.dir)
 ;;
 
 let failed_to_delete_sandbox dir reason =

test/blackbox-tests/test-cases/sandbox/patch-back-source-tree.t

@@ -34,6 +34,13 @@ All modified dependencies are promoted
 
   $ echo blah > x
   $ dune build
+  File "_build/default/x", line 1, characters 0-0:
+  --- _build/default/x
+  +++ _build/.sandbox/86f2c40130a800b8151676d70b10262e/default/x
+  @@ -1 +1 @@
+  -blah
+  +Hello, world!
+  [1]
 
   $ dune trace cat | jq '
   > include "dune";
@@ -82,6 +89,12 @@ All other new files are copied
   > EOF
 
   $ dune build
+  File "_build/default/y", line 1, characters 0-0:
+  --- _build/default/y
+  +++ _build/.sandbox/ba441369ce7d90755f539d06c1f02c22/default/y
+  @@ -0,0 +1 @@
+  +Hello, world!
+  [1]
   $ dune promote
   Promoting _build/default/y to y.
   $ cat y
@@ -98,6 +111,12 @@ Directories are created if needed
   > EOF
 
   $ dune build
+  File "_build/default/z/z", line 1, characters 0-0:
+  --- _build/default/z/z
+  +++ _build/.sandbox/99313b6fe2aa282ac731133ff51ddc94/default/z/z
+  @@ -0,0 +1 @@
+  +Hello, world!
+  [1]
   $ dune promote
   Promoting _build/default/z/z to z/z.
   $ cat z/z
@@ -116,6 +135,13 @@ Actions are allowed to delete files
   > EOF
 
   $ dune build
+  File "dune", lines 1-4, characters 0-96:
+  1 | (rule
+  2 |  (deps foo (sandbox patch_back_source_tree))
+  3 |  (alias default)
+  4 |  (action (system "rm foo")))
+  Error: File foo should be deleted
+  [1]
   $ dune promote
   $ [[ ! -f foo ]] && echo foo has been deleted
   foo has been deleted
@@ -134,6 +160,25 @@ Actions are allowed to delete directories
   > EOF
 
   $ dune build
+  File "dune", lines 1-4, characters 0-116:
+  1 | (rule
+  2 |  (deps todelete/y/foo (sandbox patch_back_source_tree))
+  3 |  (alias default)
+  4 |  (action (system "rm -rf todelete")))
+  Error: Directory todelete should be deleted
+  File "dune", lines 1-4, characters 0-116:
+  1 | (rule
+  2 |  (deps todelete/y/foo (sandbox patch_back_source_tree))
+  3 |  (alias default)
+  4 |  (action (system "rm -rf todelete")))
+  Error: Directory todelete/y should be deleted
+  File "dune", lines 1-4, characters 0-116:
+  1 | (rule
+  2 |  (deps todelete/y/foo (sandbox patch_back_source_tree))
+  3 |  (alias default)
+  4 |  (action (system "rm -rf todelete")))
+  Error: File todelete/y/foo should be deleted
+  [1]
 
   $ dune promote
   $ [[ ! -d todelete ]] && echo todelete has been deleted
@@ -198,12 +243,27 @@ the rule:
   > }
 
   $ test_with copy
+  File "_build/default/x", line 1, characters 0-0:
+  --- _build/default/x
+  +++ _build/.sandbox/e9782accaad816d62e1b8df11fc7ba71/default/x
+  @@ -0,0 +1 @@
+  +Hello, world!
   Promoting _build/default/x to x.
   Hello, world!
   $ test_with hardlink
+  File "_build/default/x", line 1, characters 0-0:
+  --- _build/default/x
+  +++ _build/.sandbox/e9782accaad816d62e1b8df11fc7ba71/default/x
+  @@ -0,0 +1 @@
+  +Hello, world!
   Promoting _build/default/x to x.
   Hello, world!
   $ test_with symlink
+  File "_build/default/x", line 1, characters 0-0:
+  --- _build/default/x
+  +++ _build/.sandbox/e9782accaad816d62e1b8df11fc7ba71/default/x
+  @@ -0,0 +1 @@
+  +Hello, world!
   Promoting _build/default/x to x.
   Hello, world!
 
@@ -227,6 +287,13 @@ If a source file is read-only, the action sees it as writable:
 
   $ dune build
   writable
+  File "_build/default/x", line 1, characters 0-0:
+  --- _build/default/x
+  +++ _build/.sandbox/f7a07be918688b38bde181bb8be9d91d/default/x
+  @@ -1 +1 @@
+  -xx
+  +blah
+  [1]
 
 And as the action modified `x`, its permissions have now changed
 inside the source tree: