diff --git a/CHANGES.md b/CHANGES.md index 1169df0216d..a762aba2863 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -99,6 +99,11 @@ already end in .exe. Second, when resolving binary names, .opt variants are no longer chosen automatically. (#2543, @nojb) +- 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. (#2486, @aalekseyev, fixes #2482) + 1.11.0 (23/07/2019) ------------------- diff --git a/src/dune/action_exec.ml b/src/dune/action_exec.ml index 2b734300cf1..cc0ab460446 100644 --- a/src/dune/action_exec.ml +++ b/src/dune/action_exec.ml @@ -141,31 +141,22 @@ let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to ~stdin_from = Digest.generic data in exec_echo stdout_to (Digest.to_string_raw s) - | Diff ({ optional = _; file1; file2; mode } as diff) -> - if Diff.eq_files diff then - Fiber.return () - else - 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 - 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)) - }; + | 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 + (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 + Fiber.finalize (fun () -> if mode = Binary then User_error.raise [ Pp.textf "Files %s and %s differ." @@ -173,8 +164,32 @@ let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to ~stdin_from = (Path.to_string_maybe_quoted file2) ] else - Print_diff.print file1 file2 - ~skip_trailing_cr:(mode = Text && Sys.win32) + 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 = List.fold_left diff --git a/src/dune/print_diff.ml b/src/dune/print_diff.ml index 3bbbe169e99..d748b58e11e 100644 --- a/src/dune/print_diff.ml +++ b/src/dune/print_diff.ml @@ -18,8 +18,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 () = diff --git a/src/dune/promotion.ml b/src/dune/promotion.ml index fb2feb5e361..1f602c04f20 100644 --- a/src/dune/promotion.ml +++ b/src/dune/promotion.ml @@ -1,44 +1,80 @@ 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); ("dst", Path.Source.to_dyn dst) ] + 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 + (if correction_exists then + Format.sprintf "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) () + (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 () = File.db := [] let () = Hooks.End_of_build.always clear_cache -module P = Persistent.Make (struct - type t = File.t list - - let name = "TO-PROMOTE" - - let version = 1 -end) +module P = Persistent.Make(struct + type t = File.t list + let name = "TO-PROMOTE" + let version = 2 + end) let db_file = Path.relative Path.build_dir ".to-promote" @@ -53,10 +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 @@ -81,39 +119,45 @@ let do_promote db files_to_promote = let dirs_to_clear_from_cache = Path.root :: potential_build_contexts in let promote_one dst srcs = match srcs with - | [] -> - assert false - | src :: 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. *) - 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 -> - Format.eprintf " -> ignored %s.@." - (Path.to_string_maybe_quoted (Path.build path))) + | [] -> assert false + | (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. + + 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; staging; dst }; + List.iter others ~f:(fun (path, _staging) -> + Format.eprintf " -> ignored %s.@." + (Path.to_string_maybe_quoted (Path.build path))) in match files_to_promote with | All -> Path.Source.Map.iteri by_targets ~f:promote_one; [] | These (files, on_missing) -> - let files = Path.Source.Set.of_list files |> Path.Source.Set.to_list in - let by_targets = - List.fold_left files ~init:by_targets ~f:(fun map fn -> - match Path.Source.Map.find by_targets fn with - | None -> - on_missing fn; - map - | Some srcs -> - promote_one fn srcs; - Path.Source.Map.remove by_targets fn) - in - Path.Source.Map.to_list by_targets - |> List.concat_map ~f:(fun (dst, srcs) -> - List.map srcs ~f:(fun src -> { File.src; dst })) + let files = + Path.Source.Set.of_list files |> Path.Source.Set.to_list + in + let by_targets = + List.fold_left files ~init:by_targets ~f:(fun map fn -> + match Path.Source.Map.find by_targets fn with + | None -> + on_missing fn; + map + | Some srcs -> + promote_one fn srcs; + Path.Source.Map.remove by_targets fn) + in + Path.Source.Map.to_list by_targets + |> List.concat_map ~f:(fun (dst, srcs) -> + List.map srcs ~f:(fun (src, staging) -> { File.src; staging; dst })) let finalize () = let db = diff --git a/src/dune/promotion.mli b/src/dune/promotion.mli index d8d410312ee..e7d935022b2 100644 --- a/src/dune/promotion.mli +++ b/src/dune/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 dump the diff --git a/src/stdune/path.ml b/src/stdune/path.ml index 1feeb862b9b..da3f600a718 100644 --- a/src/stdune/path.ml +++ b/src/stdune/path.ml @@ -816,7 +816,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 @@ -1140,6 +1140,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 -> diff --git a/src/stdune/path.mli b/src/stdune/path.mli index 92b3827f242..724f433bb10 100644 --- a/src/stdune/path.mli +++ b/src/stdune/path.mli @@ -249,6 +249,8 @@ 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 diff --git a/test/blackbox-tests/test-cases/corrections/run.t b/test/blackbox-tests/test-cases/corrections/run.t index 4e030d1344f..d2d94804200 100644 --- a/test/blackbox-tests/test-cases/corrections/run.t +++ b/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.