Refactor sandboxed directory targets

We had similar but subtly different code for sandboxed and non-sandboxed directory targets. This patch unifies the two.

We also no longer promote empty (sub)directories. Previously, this was only the case for sandboxed directory targets because we didn't move empty (sub)directories from the sandbox to the build dir.

Signed-off-by: Roman Leshchinskiy <rleshchinskiy@janestreet.com>

src/dune_engine/rule_cache.ml

@@ -108,7 +108,7 @@ module Workspace_local = struct
       | Targets_missing
       | Dynamic_deps_changed
       | Always_rerun
-      | Error_while_collecting_directory_targets of Unix_error.Detailed.t
+      | Error_while_collecting_directory_targets of Targets.Produced.Error.t
 
     let report ~head_target reason =
       let reason =
@@ -123,10 +123,10 @@ module Workspace_local = struct
         | Targets_changed -> "target changed in build dir"
         | Always_rerun -> "not trying to use the cache"
         | Dynamic_deps_changed -> "dynamic dependencies changed"
-        | Error_while_collecting_directory_targets unix_error ->
+        | Error_while_collecting_directory_targets error ->
           sprintf
             "error while collecting directory targets: %s"
-            (Unix_error.Detailed.to_string_hum unix_error)
+            (Targets.Produced.Error.to_string_hum error)
       in
       Console.print_user_message
         (User_message.make
@@ -143,7 +143,7 @@ module Workspace_local = struct
     : (Digest.t Targets.Produced.t, Miss_reason.t) Result.t
     =
     match Targets.Produced.of_validated targets with
-    | Error (_, unix_error) -> Miss (Error_while_collecting_directory_targets unix_error)
+    | Error error -> Miss (Error_while_collecting_directory_targets error)
     | Ok targets ->
       (match
          Targets.Produced.Option.mapi targets ~f:(fun target () ->

src/dune_engine/sandbox.ml

@@ -244,53 +244,6 @@ let rename_optional_file ~src ~dst =
      | () -> ())
 ;;
 
-(* Recursively collect regular files from [src] to [dst] and return the set of
-   of files collected. *)
-let collect_dir_recursively ~loc ~src_dir ~dst_dir =
-  let rec loop ~src_dir ~dst_dir =
-    match
-      Dune_filesystem_stubs.read_directory_with_kinds (Path.Build.to_string src_dir)
-    with
-    | Ok files ->
-      List.map files ~f:(fun (file, kind) ->
-        match (kind : File_kind.t) with
-        | S_LNK
-          (* TODO symlinks outside of the sandbox are going to be broken,
-             but users shouldn't be doing this anyway. *)
-        | S_REG -> Appendable_list.singleton (dst_dir, file)
-        | S_DIR ->
-          loop
-            ~src_dir:(Path.Build.relative src_dir file)
-            ~dst_dir:(Path.Build.relative dst_dir file)
-        | _ ->
-          User_error.raise
-            ~loc
-            [ Pp.textf
-                "Rule produced a file with unrecognised kind %S"
-                (File_kind.to_string kind)
-            ])
-      |> Appendable_list.concat
-    | Error (ENOENT, _, _) ->
-      User_error.raise
-        ~loc
-        [ Pp.textf
-            "Rule failed to produce directory %S"
-            (Path.Build.drop_build_context_maybe_sandboxed_exn src_dir
-             |> Path.Source.to_string_maybe_quoted)
-        ]
-    | Error (unix_error, _, _) ->
-      User_error.raise
-        ~loc
-        [ Pp.textf
-            "Rule produced unreadable directory %S"
-            (Path.Build.drop_build_context_maybe_sandboxed_exn src_dir
-             |> Path.Source.to_string_maybe_quoted)
-        ; Pp.verbatim (Unix.error_message unix_error)
-        ]
-  in
-  loop ~src_dir ~dst_dir
-;;
-
 let apply_changes_to_source_tree t ~old_snapshot =
   let new_snapshot = snapshot t in
   (* Same as promotion: make the file writable when copying to the source
@@ -332,16 +285,16 @@ let hint_delete_dir =
 let move_targets_to_build_dir t ~loc ~should_be_skipped ~(targets : Targets.Validated.t)
   : unit Targets.Produced.t Fiber.t
   =
-  maybe_async (fun () ->
-    Option.iter t.snapshot ~f:(fun old_snapshot ->
-      apply_changes_to_source_tree t ~old_snapshot);
-    Path.Build.Set.iter targets.files ~f:(fun target ->
-      if not (should_be_skipped target)
-      then rename_optional_file ~src:(map_path t target) ~dst:target);
-    let discovered_targets =
-      Path.Build.Set.to_list_map targets.dirs ~f:(fun target ->
+  let open Fiber.O in
+  let* () =
+    maybe_async (fun () ->
+      Option.iter t.snapshot ~f:(fun old_snapshot ->
+        apply_changes_to_source_tree t ~old_snapshot);
+      Path.Build.Set.iter targets.files ~f:(fun target ->
+        if not (should_be_skipped target)
+        then rename_optional_file ~src:(map_path t target) ~dst:target);
+      Path.Build.Set.iter targets.dirs ~f:(fun target ->
         let src_dir = map_path t target in
-        let files = collect_dir_recursively ~loc ~src_dir ~dst_dir:target in
         (match Path.Untracked.stat (Path.build target) with
          | Error (Unix.ENOENT, _, _) -> ()
          | Error e ->
@@ -362,12 +315,10 @@ let move_targets_to_build_dir t ~loc ~should_be_skipped ~(targets : Targets.Vali
                  (Path.Build.to_string_maybe_quoted target)
                  (File_kind.to_string_hum st_kind)
              ]);
-        Path.rename (Path.build src_dir) (Path.build target);
-        files)
-      |> Appendable_list.concat
-      |> Appendable_list.to_list
-    in
-    Targets.Produced.expand_validated_exn targets discovered_targets)
+        if Path.Untracked.exists (Path.build src_dir)
+        then Path.rename (Path.build src_dir) (Path.build target)))
+  in
+  Targets.Produced.produced_after_rule_executed_exn ~loc targets
 ;;
 
 let failed_to_delete_sandbox dir reason =

src/dune_engine/targets.ml

@@ -118,10 +118,49 @@ module Produced = struct
     ; dirs : 'a Filename.Map.t Path.Build.Map.t
     }
 
+  module Error = struct
+    type t =
+      | Missing_dir of Path.Build.t
+      | Unreadable_dir of Path.Build.t * Unix_error.Detailed.t
+      | Unsupported_file of Path.Build.t * File_kind.t
+
+    let message = function
+      | Missing_dir dir ->
+        [ Pp.textf
+            "Rule failed to produce directory %S"
+            (Path.Build.drop_build_context_maybe_sandboxed_exn dir
+             |> Path.Source.to_string_maybe_quoted)
+        ]
+      | Unreadable_dir (dir, (unix_error, _, _)) ->
+        (* CR-soon amokhov: This case is untested. *)
+        [ Pp.textf
+            "Rule produced unreadable directory %S"
+            (Path.Build.drop_build_context_maybe_sandboxed_exn dir
+             |> Path.Source.to_string_maybe_quoted)
+        ; Pp.verbatim (Unix.error_message unix_error)
+        ]
+      | Unsupported_file (file, kind) ->
+        (* CR-soon amokhov: This case is untested. *)
+        [ Pp.textf
+            "Rule produced file %S with unrecognised kind %S"
+            (Path.Build.drop_build_context_maybe_sandboxed_exn file
+             |> Path.Source.to_string_maybe_quoted)
+            (File_kind.to_string kind)
+        ]
+    ;;
+
+    let to_string_hum = function
+      | Missing_dir _ -> "missing directory"
+      | Unreadable_dir (_, unix_error) -> Unix_error.Detailed.to_string_hum unix_error
+      | Unsupported_file _ -> "unsupported file kind"
+    ;;
+  end
+
   let of_validated =
-    let rec collect dir : (unit Filename.Map.t Path.Build.Map.t, _) result =
+    let rec collect dir : (unit Filename.Map.t Path.Build.Map.t, Error.t) result =
       match Path.Untracked.readdir_unsorted_with_kinds (Path.build dir) with
-      | Error e -> Error (`Directory dir, e)
+      | Error (Unix.ENOENT, _, _) -> Error (Missing_dir dir)
+      | Error e -> Error (Unreadable_dir (dir, e))
       | Ok dir_contents ->
         let open Result.O in
         let+ filenames, dirs =
@@ -130,13 +169,17 @@ module Produced = struct
             ~init:(Filename.Map.empty, Path.Build.Map.empty)
             ~f:(fun (acc_filenames, acc_dirs) (filename, kind) ->
               match (kind : File_kind.t) with
-              | S_REG -> Ok (Filename.Map.add_exn acc_filenames filename (), acc_dirs)
+              (* CR-someday rleshchinskiy: Make semantics of symlinks more consistent. *)
+              | S_LNK | S_REG ->
+                Ok (String.Map.add_exn acc_filenames filename (), acc_dirs)
               | S_DIR ->
                 let+ dir = collect (Path.Build.relative dir filename) in
                 acc_filenames, Path.Build.Map.union_exn acc_dirs dir
-              | _ -> Ok (acc_filenames, acc_dirs))
+              | _ -> Error (Unsupported_file (Path.Build.relative dir filename, kind)))
         in
-        Path.Build.Map.add_exn dirs dir filenames
+        if not (String.Map.is_empty filenames)
+        then Path.Build.Map.add_exn dirs dir filenames
+        else dirs
     in
     fun (validated : Validated.t) ->
       match Path.Build.Set.to_list_map validated.dirs ~f:collect |> Result.List.all with
@@ -158,49 +201,13 @@ module Produced = struct
     maybe_async (fun () -> of_validated targets)
     >>| function
     | Ok t -> t
-    | Error (`Directory dir, (Unix.ENOENT, _, _)) ->
-      User_error.raise
-        ~loc
-        [ Pp.textf
-            "Rule failed to produce directory %S"
-            (Path.Build.drop_build_context_maybe_sandboxed_exn dir
-             |> Path.Source.to_string_maybe_quoted)
-        ]
-    | Error (`Directory dir, (unix_error, _, _)) ->
-      User_error.raise
-        ~loc
-        [ Pp.textf
-            "Rule produced unreadable directory %S"
-            (Path.Build.drop_build_context_maybe_sandboxed_exn dir
-             |> Path.Source.to_string_maybe_quoted)
-        ; Pp.verbatim (Unix.error_message unix_error)
-        ]
+    | Error error -> User_error.raise ~loc (Error.message error)
   ;;
 
   let of_file_list_exn list =
     { files = Path.Build.Map.of_list_exn list; dirs = Path.Build.Map.empty }
   ;;
 
-  let expand_validated_exn (validated : Validated.t) dir_filename_pairs =
-    let files = Path.Build.Set.to_map validated.files ~f:(fun (_ : Path.Build.t) -> ()) in
-    let dirs =
-      Path.Build.Map.of_list_multi dir_filename_pairs
-      |> Path.Build.Map.map ~f:(Filename.Map.of_list_map_exn ~f:(fun file -> file, ()))
-    in
-    let is_unexpected dir =
-      not
-        (Path.Build.Set.exists validated.dirs ~f:(fun validated_dir ->
-           Path.Build.is_descendant dir ~of_:validated_dir))
-    in
-    Path.Build.Map.iteri dirs ~f:(fun dir _ ->
-      if is_unexpected dir
-      then
-        Code_error.raise
-          "Targets.Produced.expand_validated_exn: Unexpected directory."
-          [ "validated", Validated.to_dyn validated; "dir", Path.Build.to_dyn dir ]);
-    { files; dirs }
-  ;;
-
   let all_files { files; dirs } =
     let disallow_duplicates file _payload1 _payload2 =
       Code_error.raise

src/dune_engine/targets.mli

@@ -76,24 +76,25 @@ module Produced : sig
     ; dirs : 'a Filename.Map.t Path.Build.Map.t
     }
 
+  module Error : sig
+    type t
+
+    val message : t -> 'a Pp.t list
+    val to_string_hum : t -> string
+  end
+
   (** Expand [targets : Validated.t] by recursively traversing directory targets
       and collecting all contained files. *)
-  val of_validated
-    :  Validated.t
-    -> (unit t, [ `Directory of Path.Build.t ] * Unix_error.Detailed.t) result
+  val of_validated : Validated.t -> (unit t, Error.t) result
 
   (** Like [of_validated] but assumes the targets have been just produced by a
-      rule. If some directory targets aren't readable, an error is raised *)
+      rule. If some directory targets aren't readable, an error is raised. *)
   val produced_after_rule_executed_exn : loc:Loc.t -> Validated.t -> unit t Fiber.t
 
   (** Populates only the [files] field, leaving [dirs] empty. Raises a code
       error if the list contains duplicates. *)
   val of_file_list_exn : (Path.Build.t * Digest.t) list -> Digest.t t
 
-  (** Add a list of discovered directory-filename pairs to [Validated.t]. Raises
-      a code error on an unexpected directory. *)
-  val expand_validated_exn : Validated.t -> (Path.Build.t * Filename.t) list -> unit t
-
   (** Union of [t.files] and all files in [t.dirs]. *)
   val all_files : 'a t -> 'a Path.Build.Map.t
 

test/blackbox-tests/test-cases/start-install-dst-with-parent-error.t

@@ -209,7 +209,7 @@ Test that on older versions of dune we don't get warnings in this case:
   ]
   etc: [
     "_build/install/default/etc/b" {"../b"}
-    "_build/install/default/etc/baz/baz.txt" {"../baz/baz.txt"}
+    "_build/install/default/etc/baz/b.txt" {"../baz/b.txt"}
   ]
 
 Test that we don't get the warning if a vendored project starts an install dst