From 0bfcfdb61d74c66ae70bfe54506f57e904f45037 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 10 Oct 2023 10:20:04 -0600 Subject: [PATCH] fix: make copying sandbox files writeable Signed-off-by: Rudi Grinberg --- doc/changes/8920.md | 1 + src/dune_engine/sandbox.ml | 79 +++++++++++++------ .../directory-targets/copy-sandboxing.t | 8 +- .../sandboxing-stale-directory-target.t | 2 +- 4 files changed, 63 insertions(+), 27 deletions(-) create mode 100644 doc/changes/8920.md diff --git a/doc/changes/8920.md b/doc/changes/8920.md new file mode 100644 index 00000000000..d70ef16cc6f --- /dev/null +++ b/doc/changes/8920.md @@ -0,0 +1 @@ +- Dependencies in the copying sandbox are now writeable (#8920, @rgrinberg) diff --git a/src/dune_engine/sandbox.ml b/src/dune_engine/sandbox.ml index 4a16ccf7301..806055b894c 100644 --- a/src/dune_engine/sandbox.ml +++ b/src/dune_engine/sandbox.ml @@ -41,26 +41,60 @@ type t = let dir t = t.dir let map_path t p = Path.Build.append t.dir p -let rec copy_recursively (src_kind : Unix.file_kind) ~src ~dst = - match src_kind with - | S_REG -> Io.copy_file ~src ~dst () - | S_DIR -> - (match Path.Untracked.readdir_unsorted_with_kinds src with - | Error e -> Unix_error.Detailed.raise e - | Ok contents -> - Path.mkdir_p dst; - List.iter contents ~f:(fun (name, kind) -> - copy_recursively kind ~src:(Path.relative src name) ~dst:(Path.relative dst name))) - | _ -> - User_error.raise - ~hints: - [ Pp.text "re-run dune to delete the stale artifact, or manually delete this file" +module Item = struct + type t = + | File + | Directory of { perms : int } + | Other of Unix.file_kind + + let of_path path = + let { Unix.st_kind; st_perm; _ } = Path.Untracked.stat_exn path in + match st_kind with + | S_DIR -> Directory { perms = st_perm } + | S_REG -> File + | kind -> Other kind + ;; + + let of_kind path (kind : Unix.file_kind) = + match kind with + | S_DIR -> Directory { perms = (Path.Untracked.stat_exn path).st_perm } + | S_REG -> File + | _ -> Other kind + ;; +end + +let copy_recursively = + let chmod_file = Path.Permissions.add Path.Permissions.write in + let chmod_dir p = + Path.Permissions.add Path.Permissions.execute p + |> Path.Permissions.add Path.Permissions.write + in + let rec loop item ~src ~dst = + match (item : Item.t) with + | File -> Io.copy_file ~chmod:chmod_file ~src ~dst () + | Directory { perms } -> + (match Path.Untracked.readdir_unsorted_with_kinds src with + | Error e -> Unix_error.Detailed.raise e + | Ok contents -> + let perms = chmod_dir perms in + Path.mkdir_p ~perms dst; + List.iter contents ~f:(fun (name, kind) -> + let src = Path.relative src name in + let item = Item.of_kind src kind in + loop item ~src ~dst:(Path.relative dst name))) + | Other kind -> + User_error.raise + ~hints: + [ Pp.text + "Re-run Dune to delete the stale artifact, or manually delete this file" + ] + [ Pp.textf + "Failed to copy file %s of kind %S while creating a copy sandbox" + (Path.to_string_maybe_quoted src) + (File_kind.to_string_hum kind) ] - [ Pp.textf - "Failed to copy file %s of kind %s while creating a copy sandbox" - (Path.to_string_maybe_quoted src) - (File_kind.to_string_hum src_kind) - ] + in + loop ;; let create_dirs t ~deps ~rule_dir = @@ -90,8 +124,8 @@ let link_function ~(mode : Sandbox_mode.some) = | false -> fun src dst -> Io.portable_symlink ~src ~dst) | Copy -> fun src dst -> - let { Unix.st_kind; _ } = Path.Untracked.stat_exn src in - copy_recursively st_kind ~src ~dst + let what = Item.of_path src in + copy_recursively what ~src ~dst | Hardlink -> (match Sys.win32 with | true -> win32_error mode @@ -99,6 +133,7 @@ let link_function ~(mode : Sandbox_mode.some) = | Patch_back_source_tree -> (* We need to let the action modify its dependencies, so we copy dependencies and make them writable. *) + (* CR-someday: this doesn't work with directory targets *) let chmod = Path.Permissions.add Path.Permissions.write in fun src dst -> Io.copy_file ~src ~dst ~chmod ()) ;; @@ -318,7 +353,7 @@ let move_targets_to_build_dir t ~loc ~should_be_skipped ~(targets : Targets.Vali User_error.raise ~hints:hint_delete_dir [ Pp.textf - "Target %s of kind %s already exists in the build directory" + "Target %s of kind %S already exists in the build directory" (Path.Build.to_string_maybe_quoted target) (File_kind.to_string_hum st_kind) ]); diff --git a/test/blackbox-tests/test-cases/directory-targets/copy-sandboxing.t b/test/blackbox-tests/test-cases/directory-targets/copy-sandboxing.t index 4d64bd2452f..1cf2a390d0c 100644 --- a/test/blackbox-tests/test-cases/directory-targets/copy-sandboxing.t +++ b/test/blackbox-tests/test-cases/directory-targets/copy-sandboxing.t @@ -60,13 +60,13 @@ mode: permissions of output/ 755 permissions of output/y - 444 + 644 permissions of output/x - 444 + 644 permissions of output/subdir - 755 + 754 permissions of output/subdir/z - 444 + 644 $ ( cd _build/default && ../../print-permissions.sh ) diff --git a/test/blackbox-tests/test-cases/sandboxing-stale-directory-target.t b/test/blackbox-tests/test-cases/sandboxing-stale-directory-target.t index b8e797f53dc..f0ae9039b8b 100644 --- a/test/blackbox-tests/test-cases/sandboxing-stale-directory-target.t +++ b/test/blackbox-tests/test-cases/sandboxing-stale-directory-target.t @@ -16,7 +16,7 @@ A faulty test escapes the sandbox by creating its target outside the sandbox 1 | (rule 2 | (target (dir foo)) 3 | (action (system "mkdir $TESTCASE_ROOT/_build/default/foo && mkdir foo"))) - Error: Target _build/default/foo of kind directory already exists in the + Error: Target _build/default/foo of kind "directory" already exists in the build directory Hint: delete this file manually or check the permissions of the parent directory of this file