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

@@ -146,24 +146,28 @@ let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to =
         | 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 () ->
+          if is_copied_from_source_tree file1 &&
+             not (is_copied_from_source_tree file2) then begin
+            Promotion.File.register
+              ~source_file:
+                (snd (Option.value_exn (
+                   Path.extract_build_context_dir_maybe_sandboxed file1)))
+              ~correction_file:
+                (snd (Path.Build.split_sandbox_root (
+                   Path.as_in_build_dir_exn file2)))
+          end;
+          Fiber.return ()
+        )
     end
   | Merge_files_into (sources, extras, target) ->
     let lines =

src/promotion.ml

@@ -1,34 +1,53 @@
 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
     ; 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", Path.Build.to_dyn staging
       ; "dst", Path.Source.to_dyn dst
       ]
 
   let db : t list ref = ref []
 
-  let register t = db := t :: !db
+  let register ~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);
+    db := { src = correction_file; staging; dst = source_file } :: !db
 
-  let promote { src; dst } =
-    let src_exists = Path.exists (Path.build src) in
+  let promote { src; staging; dst } =
+    let staging_exists = Path.exists (Path.build staging) 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 staging_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 staging file (%s) is missing.@.")
+           (Path.to_string_maybe_quoted (Path.build src))
+           (Path.to_string_maybe_quoted (Path.build staging))
+           (Path.Source.to_string_maybe_quoted dst))
+    ;
+    if staging_exists then
+      Io.copy_file ~src:(Path.build staging) ~dst:(Path.source dst) ()
 end
 
 let clear_cache () =
@@ -54,11 +73,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 +102,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 +139,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

@@ -3,13 +3,14 @@ open! Stdune
 module File : sig
   type t =
     { src : Path.Build.t
+    ; staging : Path.Build.t
     ; dst : Path.Source.t
     }
 
   val to_dyn : t -> Dyn.t
 
   (** Register a file to promote *)
-  val register : t -> unit
+  val register : source_file:Path.Source.t -> correction_file:Path.Build.t -> unit
 end
 
 (** Promote all registered files if [!Clflags.auto_promote]. Otherwise