Skip to content

Commit

Permalink
introduce promotion staging area
Browse files Browse the repository at this point in the history
Signed-off-by: Arseniy Alekseyev <aalekseyev@janestreet.com>
  • Loading branch information
aalekseyev committed Aug 2, 2019
1 parent e26d134 commit 954fc3f
Show file tree
Hide file tree
Showing 8 changed files with 142 additions and 56 deletions.
5 changes: 5 additions & 0 deletions CHANGES.md
Original file line number Diff line number Diff line change
Expand Up @@ -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)
-------------------

Expand Down
61 changes: 41 additions & 20 deletions src/action_exec.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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 =
Expand Down
4 changes: 2 additions & 2 deletions src/print_diff.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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 () =
Expand Down
86 changes: 63 additions & 23 deletions src/promotion.ml
Original file line number Diff line number Diff line change
@@ -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 () =
Expand All @@ -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"
Expand All @@ -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
Expand 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
Expand All @@ -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 =
Expand Down
27 changes: 21 additions & 6 deletions src/promotion.mli
Original file line number Diff line number Diff line change
@@ -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
Expand Down
7 changes: 6 additions & 1 deletion src/stdune/path.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
2 changes: 2 additions & 0 deletions src/stdune/path.mli
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
6 changes: 2 additions & 4 deletions test/blackbox-tests/test-cases/corrections/run.t
Original file line number Diff line number Diff line change
Expand Up @@ -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.
Expand Down

0 comments on commit 954fc3f

Please sign in to comment.