From 954fc3fe1c8400d52c89a0086e42c174d4b018b2 Mon Sep 17 00:00:00 2001 From: Arseniy Alekseyev Date: Fri, 2 Aug 2019 16:03:32 +0100 Subject: [PATCH] introduce promotion staging area Signed-off-by: Arseniy Alekseyev --- CHANGES.md | 5 ++ src/action_exec.ml | 61 ++++++++----- src/print_diff.ml | 4 +- src/promotion.ml | 86 ++++++++++++++----- src/promotion.mli | 27 ++++-- src/stdune/path.ml | 7 +- src/stdune/path.mli | 2 + .../test-cases/corrections/run.t | 6 +- 8 files changed, 142 insertions(+), 56 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 85662e85da6b..f067b6a7849a 100644 --- a/CHANGES.md +++ b/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) ------------------- diff --git a/src/action_exec.ml b/src/action_exec.ml index 150375c2058e..bd482f3f1f9e 100644 --- a/src/action_exec.ml +++ b/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 = diff --git a/src/print_diff.ml b/src/print_diff.ml index 14b406700579..dd3c924dadcc 100644 --- a/src/print_diff.ml +++ b/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 () = diff --git a/src/promotion.ml b/src/promotion.ml index bb5d160eb06b..70f8895cc5ba 100644 --- a/src/promotion.ml +++ b/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 () = @@ -39,7 +74,7 @@ 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 + let version = 2 end) let db_file = Path.relative Path.build_dir ".to-promote" @@ -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 = diff --git a/src/promotion.mli b/src/promotion.mli index c2afc8cda983..3bf6e5f70af5 100644 --- a/src/promotion.mli +++ b/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 diff --git a/src/stdune/path.ml b/src/stdune/path.ml index 4d53a506a3fc..e2869270642b 100644 --- a/src/stdune/path.ml +++ b/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 diff --git a/src/stdune/path.mli b/src/stdune/path.mli index a4f728dbad4c..ed720a861d10 100644 --- a/src/stdune/path.mli +++ b/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 diff --git a/test/blackbox-tests/test-cases/corrections/run.t b/test/blackbox-tests/test-cases/corrections/run.t index 4e030d1344ff..d2d948042003 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.