ocaml · rgrinberg · Oct 17, 2023 · Oct 10, 2023
diff --git a/doc/changes/8920.md 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
@@ -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,15 +124,16 @@ 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
         | false -> fun src dst -> Io.portable_hardlink ~src ~dst)
      | 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
@@ -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
@@ -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
Original file line number	Diff line number	Diff line change
		@@ -0,0 +1 @@
		- Dependencies in the copying sandbox are now writeable (#8920, @rgrinberg)