introduce promotion staging area

Signed-off-by: Arseniy Alekseyev <aalekseyev@janestreet.com>

CHANGES.md

@@ -65,6 +65,11 @@
 - In `(diff? x y)` action, require `x` to exist and register a 
   dependency on that file. (#2486, @aalekseyev)
 
+- Make `(diff? x y)` move the correction file (`y`) away from the build 
+  directory to promotion staging area.
+  This makes corrections work with sandboxing and in general reduces build 
+  directory pollution.
+
 1.11.0 (23/07/2019)
 -------------------
 

src/action_exec.ml

@@ -137,33 +137,54 @@ let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to =
       Digest.generic data
     in
     exec_echo stdout_to (Digest.to_string_raw s)
-  | Diff ({ optional = _; file1; file2; mode } as diff) ->
+  | Diff ({ optional; file1; file2; mode } as diff) ->
+    let remove_intermediate_file () =
+      if optional then
+        (try Path.unlink file2 with
+         | (Unix.Unix_error (ENOENT, _, _)) -> ())
+    in
     if Diff.eq_files diff then
-      Fiber.return ()
+      (remove_intermediate_file ();
+       Fiber.return ())
     else begin
       let is_copied_from_source_tree file =
         match Path.extract_build_context_dir_maybe_sandboxed file with
         | None -> false
         | Some (_, file) -> Path.exists (Path.source file)
       in
-      if is_copied_from_source_tree file1 &&
-         not (is_copied_from_source_tree file2) then begin
-        Promotion.File.register
-          { src = snd (Path.Build.split_sandbox_root (
-              Path.as_in_build_dir_exn file2))
-          ; dst = snd (Option.value_exn (
-              Path.extract_build_context_dir_maybe_sandboxed file1))
-          }
-      end;
-      if mode = Binary then
-        User_error.raise
-          [ Pp.textf "Files %s and %s differ."
-              (Path.to_string_maybe_quoted file1)
-              (Path.to_string_maybe_quoted file2)
-          ]
-      else
-        Print_diff.print file1 file2
-          ~skip_trailing_cr:(mode = Text && Sys.win32)
+      Fiber.finalize (fun () ->
+        if mode = Binary then
+          User_error.raise
+            [ Pp.textf "Files %s and %s differ."
+                (Path.to_string_maybe_quoted file1)
+                (Path.to_string_maybe_quoted file2)
+            ]
+        else
+          Print_diff.print file1 file2 ~skip_trailing_cr:(mode = Text && Sys.win32))
+        ~finally:(fun () ->
+          (match optional with
+          | false ->
+            if is_copied_from_source_tree file1 &&
+               (not (is_copied_from_source_tree file2)) then begin
+              Promotion.File.register_dep
+                ~source_file:
+                  (snd (Option.value_exn (
+                     Path.extract_build_context_dir_maybe_sandboxed file1)))
+                ~correction_file:
+                  (Path.as_in_build_dir_exn file2)
+            end
+          | true ->
+            if is_copied_from_source_tree file1 then begin
+              Promotion.File.register_intermediate
+                ~source_file:
+                  (snd (Option.value_exn (
+                     Path.extract_build_context_dir_maybe_sandboxed file1)))
+                ~correction_file:
+                  (Path.as_in_build_dir_exn file2)
+            end else
+              remove_intermediate_file ());
+          Fiber.return ()
+        )
     end
   | Merge_files_into (sources, extras, target) ->
     let lines =

src/print_diff.ml

@@ -19,8 +19,8 @@ let print ?(skip_trailing_cr=Sys.win32) path1 path2 =
   let fallback () =
     User_error.raise ~loc
       [ Pp.textf "Files %s and %s differ."
-          (Path.to_string_maybe_quoted path1)
-          (Path.to_string_maybe_quoted path2)
+          (Path.to_string_maybe_quoted (Path.drop_optional_sandbox_root path1))
+          (Path.to_string_maybe_quoted (Path.drop_optional_sandbox_root path2))
       ]
   in
   let normal_diff () =

src/promotion.ml

@@ -1,34 +1,69 @@
 open! Stdune
 
+let staging_area =
+  Path.Build.relative Path.Build.root ".promotion-staging"
+
 module File = struct
   type t =
     { src : Path.Build.t
+    ; staging : Path.Build.t option
     ; dst : Path.Source.t
     }
 
-  let to_dyn { src; dst } =
+  let in_staging_area source =
+    Path.Build.append_source staging_area source
+
+  let to_dyn { src; staging; dst } =
     let open Dyn.Encoder in
     record
       [ "src", Path.Build.to_dyn src
+      ; "staging", option Path.Build.to_dyn staging
       ; "dst", Path.Source.to_dyn dst
       ]
 
   let db : t list ref = ref []
 
-  let register t = db := t :: !db
-
-  let promote { src; dst } =
-    let src_exists = Path.exists (Path.build src) in
+  let register_dep ~source_file ~correction_file =
+    db :=
+      { src = snd (Path.Build.split_sandbox_root correction_file);
+        staging = None;
+        dst = source_file;
+      } :: !db
+
+  let register_intermediate ~source_file ~correction_file =
+    let staging = in_staging_area source_file in
+    Path.mkdir_p (Path.build (Option.value_exn (Path.Build.parent staging)));
+    Unix.rename
+      (Path.Build.to_string correction_file)
+      (Path.Build.to_string staging);
+    let src = snd (Path.Build.split_sandbox_root correction_file) in
+    db := { src; staging = Some staging; dst = source_file } :: !db
+
+  let promote { src; staging; dst } =
+    let correction_file =
+      Option.value staging ~default:src
+    in
+    let correction_exists = Path.exists (Path.build correction_file) in
     Console.print
-      (Format.sprintf
-         (if src_exists then
-            "Promoting %s to %s.@."
-          else
-            "Skipping promotion of %s to %s as the file is missing.@.")
-         (Path.to_string_maybe_quoted (Path.build src))
-         (Path.Source.to_string_maybe_quoted dst));
-    if src_exists then
-      Io.copy_file ~src:(Path.build src) ~dst:(Path.source dst) ()
+      (if correction_exists then
+         Format.sprintf
+           "Promoting %s to %s.@."
+           (Path.to_string_maybe_quoted (Path.build src))
+           (Path.Source.to_string_maybe_quoted dst)
+       else
+         (Format.sprintf
+            "Skipping promotion of %s to %s as the %s is missing.@.")
+           (Path.to_string_maybe_quoted (Path.build src))
+           (Path.Source.to_string_maybe_quoted dst)
+           (match staging with
+            | None -> "file"
+            | Some staging ->
+              Format.sprintf "staging file (%s)"
+                (Path.to_string_maybe_quoted (Path.build staging)))
+      )
+    ;
+    if correction_exists then
+      Io.copy_file ~src:(Path.build correction_file) ~dst:(Path.source dst) ()
 end
 
 let clear_cache () =
@@ -54,11 +89,12 @@ let dump_db db =
 let load_db () = Option.value ~default:[] (P.load db_file)
 
 let group_by_targets db =
-  List.map db ~f:(fun { File. src; dst } ->
-    (dst, src))
+  List.map db ~f:(fun { File. src; staging; dst } ->
+    (dst, (src, staging)))
   |> Path.Source.Map.of_list_multi
   (* Sort the list of possible sources for deterministic behavior *)
-  |> Path.Source.Map.map ~f:(List.sort ~compare:Path.Build.compare)
+  |> Path.Source.Map.map
+       ~f:(List.sort ~compare:(fun (x, _) (y, _) -> Path.Build.compare x y))
 
 type files_to_promote =
   | All
@@ -82,16 +118,20 @@ let do_promote db files_to_promote =
   let promote_one dst srcs =
     match srcs with
     | [] -> assert false
-    | src :: others ->
+    | (src, staging) :: others ->
       (* We remove the files from the digest cache to force a rehash
          on the next run. We do this because on OSX [mtime] is not
          precise enough and if a file is modified and promoted
          quickly, it will look like it hasn't changed even though it
-         might have. *)
+         might have.
+
+         aalekseyev: this is probably unnecessary now, depending on when
+         [do_promote] runs (before or after [invalidate_cached_timestamps])
+      *)
       List.iter dirs_to_clear_from_cache ~f:(fun dir ->
         Cached_digest.remove (Path.append_source dir dst));
-      File.promote { src; dst };
-      List.iter others ~f:(fun path ->
+      File.promote { src; staging; dst };
+      List.iter others ~f:(fun (path, _staging) ->
         Format.eprintf " -> ignored %s.@."
           (Path.to_string_maybe_quoted (Path.build path)))
   in
@@ -115,7 +155,7 @@ let do_promote db files_to_promote =
     in
     Path.Source.Map.to_list by_targets
     |> List.concat_map ~f:(fun (dst, srcs) ->
-      List.map srcs ~f:(fun src -> { File.src; dst }))
+      List.map srcs ~f:(fun (src, staging) -> { File.src; staging; dst }))
 
 let finalize () =
   let db =

src/promotion.mli

@@ -1,15 +1,30 @@
 open! Stdune
 
 module File : sig
-  type t =
-    { src : Path.Build.t
-    ; dst : Path.Source.t
-    }
+  type t
 
   val to_dyn : t -> Dyn.t
 
-  (** Register a file to promote *)
-  val register : t -> unit
+  (** Register an intermediate file to promote.
+      The build path may point to the sandbox and the file will be
+      moved to the staging area.
+  *)
+  val register_intermediate :
+    source_file:Path.Source.t ->
+    correction_file:Path.Build.t ->
+    unit
+
+  (** Register file to promote where the correction
+      file is a dependency of the current action (rather than an
+      intermediate file).
+      [correction_file] refers to a path in the build dir, not in the sandbox
+      (it can point to the sandbox, but the sandbox root will be stripped).
+  *)
+  val register_dep :
+    source_file:Path.Source.t ->
+    correction_file:Path.Build.t ->
+    unit
+
 end
 
 (** Promote all registered files if [!Clflags.auto_promote]. Otherwise

src/stdune/path.ml

@@ -753,7 +753,7 @@ module Build = struct
 end
 
 module T : sig
-  type t = private
+  type t =
     | External of External.t
     | In_source_tree of Local.t
     | In_build_dir of Local.t
@@ -1023,6 +1023,11 @@ let extract_build_context_dir_maybe_sandboxed = function
     Option.map (Build.extract_build_context_dir_maybe_sandboxed t)
       ~f:(fun (base, rest) -> in_build_dir base, rest)
 
+let drop_optional_sandbox_root = function
+  | (In_source_tree _ | External _) as x -> x
+  | In_build_dir t -> match (Build.split_sandbox_root t) with
+    | _sandbox_root, t -> (In_build_dir t : t)
+
 let extract_build_context_dir_exn t =
   match extract_build_context_dir t with
   | Some t -> t

src/stdune/path.mli

@@ -230,6 +230,8 @@ val drop_build_context_exn : t -> Source.t
 val drop_optional_build_context : t -> t
 val drop_optional_build_context_maybe_sandboxed : t -> t
 
+val drop_optional_sandbox_root : t -> t
+
 (** Drop the "_build/blah" prefix if present, return [t] if it's a source file,
     otherwise fail. *)
 val drop_optional_build_context_src_exn : t -> Source.t

test/blackbox-tests/test-cases/corrections/run.t

@@ -65,14 +65,12 @@ Promotion should work when sandboxing is used:
 
   $ dune build @correction1 --sandbox copy
   File "text-file", line 1, characters 0-0:
-  Error: Files
-  _build/.sandbox/150b972ad59fdd3e13294c94880afcfd/default/text-file and
-  _build/.sandbox/150b972ad59fdd3e13294c94880afcfd/default/text-file-corrected
+  Error: Files _build/default/text-file and _build/default/text-file-corrected
   differ.
   [1]
 
   $ dune promote
-  Skipping promotion of _build/default/text-file-corrected to text-file as the file is missing.
+  Promoting _build/default/text-file-corrected to text-file.
 
 Dependency on the second argument of diff? is *not* automatically added.
 This is fine because we think of it as an intermediate file rather than dep.