From 46011a8a65045f9817f18bf85b88870533bd390f Mon Sep 17 00:00:00 2001
From: Rudi Grinberg <me@rgrinberg.com>
Date: Mon, 11 Dec 2023 21:46:12 -0700
Subject: [PATCH] fix: replace directory symlinking with copying

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>
---
 otherlibs/stdune/src/fpath.ml   | 12 +++---
 otherlibs/stdune/src/fpath.mli  |  3 +-
 src/dune_pkg/opam_repo.ml       |  3 +-
 src/dune_rules/install_rules.ml | 71 ++++++++++++++++++++++++++++++---
 4 files changed, 76 insertions(+), 13 deletions(-)

diff --git a/otherlibs/stdune/src/fpath.ml b/otherlibs/stdune/src/fpath.ml
index 03b3623f80a6..9c2e9e975878 100644
--- a/otherlibs/stdune/src/fpath.ml
+++ b/otherlibs/stdune/src/fpath.ml
@@ -161,7 +161,7 @@ let rm_rf fn =
 ;;
 
 let traverse_files =
-  let rec loop root stack acc f =
+  let rec loop root stack acc on_file on_dir =
     match stack with
     | [] -> acc
     | dir :: dirs ->
@@ -172,18 +172,18 @@ let traverse_files =
          let stack, acc =
            List.fold_left entries ~init:(dirs, acc) ~f:(fun (stack, acc) (fname, kind) ->
              match (kind : Unix.file_kind) with
-             | S_DIR -> Filename.concat dir fname :: stack, acc
-             | S_REG -> stack, f ~dir fname acc
+             | S_DIR -> Filename.concat dir fname :: stack, on_dir ~dir fname acc
+             | S_REG -> stack, on_file ~dir fname acc
              | S_LNK ->
                let path = Filename.concat dir_path fname in
                (match (Unix.stat path).st_kind with
                 | exception Unix.Unix_error (Unix.ENOENT, _, _) -> stack, acc
                 | S_DIR -> Filename.concat dir fname :: stack, acc
-                | S_REG -> stack, f ~dir fname acc
+                | S_REG -> stack, on_file ~dir fname acc
                 | _ -> stack, acc)
              | _ -> stack, acc)
          in
-         loop root stack acc f)
+         loop root stack acc on_file on_dir)
   in
-  fun ~dir ~init ~f -> loop dir [ "" ] init f
+  fun ~dir ~init ~on_file ~on_dir -> loop dir [ "" ] init on_file on_dir
 ;;
diff --git a/otherlibs/stdune/src/fpath.mli b/otherlibs/stdune/src/fpath.mli
index 9e1586b4d247..39dee7021d7c 100644
--- a/otherlibs/stdune/src/fpath.mli
+++ b/otherlibs/stdune/src/fpath.mli
@@ -45,5 +45,6 @@ val is_root : string -> bool
 val traverse_files
   :  dir:string
   -> init:'acc
-  -> f:(dir:string -> Filename.t -> 'acc -> 'acc)
+  -> on_file:(dir:string -> Filename.t -> 'acc -> 'acc)
+  -> on_dir:(dir:string -> Filename.t -> 'acc -> 'acc)
   -> 'acc
diff --git a/src/dune_pkg/opam_repo.ml b/src/dune_pkg/opam_repo.ml
index e30dfb009e1e..fbbd703d3fda 100644
--- a/src/dune_pkg/opam_repo.ml
+++ b/src/dune_pkg/opam_repo.ml
@@ -186,7 +186,8 @@ let scan_files_entries path =
        Fpath.traverse_files
          ~dir:(Path.to_string path)
          ~init:[]
-         ~f:(fun ~dir filename acc ->
+         ~on_dir:(fun ~dir:_ _ acc -> acc)
+         ~on_file:(fun ~dir filename acc ->
            let local_path = Path.Local.relative (Path.Local.of_string dir) filename in
            local_path :: acc)
      with
diff --git a/src/dune_rules/install_rules.ml b/src/dune_rules/install_rules.ml
index 72eacc3772a2..45489f5969e7 100644
--- a/src/dune_rules/install_rules.ml
+++ b/src/dune_rules/install_rules.ml
@@ -904,6 +904,58 @@ let symlink_source_dir ~dir ~dst =
     suffix, dst, Action_builder.symlink ~src ~dst)
 ;;
 
+module Copy_dir = struct
+  module Spec = struct
+    type ('path, 'target) t = 'path * 'target
+
+    let name = "copy-dir"
+    let version = 1
+    let bimap (src, dst) f g = f src, g dst
+    let is_useful_to ~memoize = memoize
+
+    let encode (src, dst) f g =
+      Dune_sexp.List [ Dune_sexp.atom_or_quoted_string name; f src; g dst ]
+    ;;
+
+    let action (src, dst) ~ectx:_ ~eenv:_ =
+      let all =
+        Fpath.traverse_files
+          ~dir:(Path.to_string src)
+          ~init:[]
+          ~on_file:(fun ~dir fname acc -> `File (Filename.concat dir fname) :: acc)
+          ~on_dir:(fun ~dir fname acc -> `Dir (Filename.concat dir fname) :: acc)
+      in
+      List.iter all ~f:(fun p ->
+        let dir, file =
+          match p with
+          | `Dir p -> p, None
+          | `File p -> Filename.dirname p, Some p
+        in
+        (* CR-rgrinberg: too many unnecesasry stat and mkdir calls here *)
+        let perms = (Path.Untracked.stat_exn (Path.relative src dir)).st_perm in
+        Path.mkdir_p ~perms (Path.build (Path.Build.relative dst dir));
+        Option.iter file ~f:(fun f ->
+          let src = Path.relative src f in
+          let dst = Path.build @@ Path.Build.relative dst f in
+          Io.copy_file ~src ~dst ()));
+      Fiber.return ()
+    ;;
+  end
+
+  let action ~src ~dst =
+    let module M = struct
+      type path = Path.t
+      type target = Path.Build.t
+
+      module Spec = Spec
+
+      let v = src, dst
+    end
+    in
+    Action.Extension (module M)
+  ;;
+end
+
 let symlink_installed_artifacts_to_build_install
   sctx
   (entries : Install.Entry.Sourced.t list)
@@ -949,11 +1001,20 @@ let symlink_installed_artifacts_to_build_install
         { s with entry }
       in
       let action =
-        (match kind with
-         | `File -> Action_builder.symlink
-         | `Directory -> Action_builder.symlink_dir)
-          ~src
-          ~dst
+        match kind with
+        | `File -> Action_builder.symlink ~src ~dst
+        | `Directory ->
+          let action =
+            let open Action_builder.O in
+            let+ () = Action_builder.dep (Dep.file src) in
+            Copy_dir.action ~src ~dst |> Action.Full.make
+          in
+          Action_builder.with_targets
+            action
+            ~targets:
+              (Targets.create
+                 ~dirs:(Path.Build.Set.singleton dst)
+                 ~files:Path.Build.Set.empty)
       in
       Memo.return [ entry, rule action ])
 ;;