fix: symlinks in directory targets (#6219)

compute digests for symlinks present inside directory targets Signed-off-by: Rudi Grinberg <me@rgrinberg.com> ps-id: a0b24bf1-b7da-413f-a2d6-08f977cc8973 Co-authored-by: Etienne Millon <me@emillon.org>
ocaml · Oct 19, 2022 · 6bf088d · 6bf088d
1 parent 85f99b3
commit 6bf088d
Show file tree

Hide file tree

Showing 3 changed files with 63 additions and 54 deletions.
diff --git a/src/dune_digest/dune_digest.ml b/src/dune_digest/dune_digest.ml
@@ -66,13 +66,17 @@ let generic a =
   Metrics.Timer.record "generic_digest" ~f:(fun () ->
       string (Marshal.to_string a [ No_sharing ]))
 
-let file_with_executable_bit ~executable path =
+let path_with_executable_bit =
   (* We follow the digest scheme used by Jenga. *)
   let string_and_bool ~digest_hex ~bool =
     Impl.string (digest_hex ^ if bool then "\001" else "\000")
   in
+  fun ~executable ~content_digest ->
+    string_and_bool ~digest_hex:content_digest ~bool:executable
+
+let file_with_executable_bit ~executable path =
   let content_digest = file path in
-  string_and_bool ~digest_hex:content_digest ~bool:executable
+  path_with_executable_bit ~content_digest ~executable
 
 module Stats_for_digest = struct
   type t =
@@ -112,43 +116,59 @@ exception
 
 let directory_digest_version = 2
 
-let rec path_with_stats ~allow_dirs path (stats : Stats_for_digest.t) :
+let path_with_stats ~allow_dirs path (stats : Stats_for_digest.t) :
     Path_digest_result.t =
+  let rec loop path (stats : Stats_for_digest.t) =
+    match stats.st_kind with
+    | S_LNK ->
+      let executable =
+        Path.Permissions.test Path.Permissions.execute stats.st_perm
+      in
+      Dune_filesystem_stubs.Unix_error.Detailed.catch
+        (fun path ->
+          let contents = Unix.readlink (Path.to_string path) in
+          path_with_executable_bit ~executable ~content_digest:contents)
+        path
+      |> Path_digest_result.of_result
+    | S_REG ->
+      let executable =
+        Path.Permissions.test Path.Permissions.execute stats.st_perm
+      in
+      Dune_filesystem_stubs.Unix_error.Detailed.catch
+        (file_with_executable_bit ~executable)
+        path
+      |> Path_digest_result.of_result
+    | S_DIR when allow_dirs -> (
+      (* CR-someday amokhov: The current digesting scheme has collisions for files
+         and directories. It's unclear if this is actually a problem. If it turns
+         out to be a problem, we should include [st_kind] into both digests. *)
+      match Path.readdir_unsorted path with
+      | Error e -> Path_digest_result.Unix_error e
+      | Ok listing -> (
+        match
+          List.rev_map listing ~f:(fun name ->
+              let path = Path.relative path name in
+              let stats =
+                match Path.lstat path with
+                | Error e -> raise_notrace (E (`Unix_error e))
+                | Ok stat -> Stats_for_digest.of_unix_stats stat
+              in
+              let digest =
+                match loop path stats with
+                | Ok s -> s
+                | Unix_error e -> raise_notrace (E (`Unix_error e))
+                | Unexpected_kind -> raise_notrace (E `Unexpected_kind)
+              in
+              (name, digest))
+          |> List.sort ~compare:(fun (x, _) (y, _) -> String.compare x y)
+        with
+        | exception E (`Unix_error e) -> Path_digest_result.Unix_error e
+        | exception E `Unexpected_kind -> Path_digest_result.Unexpected_kind
+        | contents ->
+          Ok (generic (directory_digest_version, contents, stats.st_perm))))
+    | S_DIR | S_BLK | S_CHR | S_FIFO | S_SOCK -> Unexpected_kind
+  in
   match stats.st_kind with
-  | S_REG ->
-    let executable =
-      Path.Permissions.test Path.Permissions.execute stats.st_perm
-    in
-    Dune_filesystem_stubs.Unix_error.Detailed.catch
-      (file_with_executable_bit ~executable)
-      path
-    |> Path_digest_result.of_result
-  | S_DIR when allow_dirs -> (
-    (* CR-someday amokhov: The current digesting scheme has collisions for files
-       and directories. It's unclear if this is actually a problem. If it turns
-       out to be a problem, we should include [st_kind] into both digests. *)
-    match Path.readdir_unsorted path with
-    | Error e -> Path_digest_result.Unix_error e
-    | Ok listing -> (
-      match
-        List.rev_map listing ~f:(fun name ->
-            let path = Path.relative path name in
-            let stats =
-              match Path.lstat path with
-              | Error e -> raise_notrace (E (`Unix_error e))
-              | Ok stat -> Stats_for_digest.of_unix_stats stat
-            in
-            let digest =
-              match path_with_stats ~allow_dirs path stats with
-              | Ok s -> s
-              | Unix_error e -> raise_notrace (E (`Unix_error e))
-              | Unexpected_kind -> raise_notrace (E `Unexpected_kind)
-            in
-            (name, digest))
-        |> List.sort ~compare:(fun (x, _) (y, _) -> String.compare x y)
-      with
-      | exception E (`Unix_error e) -> Path_digest_result.Unix_error e
-      | exception E `Unexpected_kind -> Path_digest_result.Unexpected_kind
-      | contents ->
-        Ok (generic (directory_digest_version, contents, stats.st_perm))))
-  | S_DIR | S_BLK | S_CHR | S_LNK | S_FIFO | S_SOCK -> Unexpected_kind
+  | S_DIR when not allow_dirs -> Unexpected_kind
+  | S_BLK | S_CHR | S_LNK | S_FIFO | S_SOCK -> Unexpected_kind
+  | _ -> loop path stats
diff --git a/test/blackbox-tests/test-cases/directory-targets/github6168/github6168.t b/test/blackbox-tests/test-cases/directory-targets/github6168/github6168.t
@@ -16,14 +16,3 @@ Dune not recognizing it
   > EOF
 
   $ dune build @fakenode
-  File "dune", line 1, characters 0-92:
-  1 | (rule
-  2 |  (alias fakenode)
-  3 |  (targets
-  4 |   (dir fakenode_modules))
-  5 |  (action
-  6 |   (run ./fakenpm.exe)))
-  Error: This rule defines a directory target "fakenode_modules" that matches
-  the requested path "fakenode_modules" but the rule's action didn't produce it
-  -> required by alias fakenode
-  [1]
diff --git a/test/expect-tests/digest/digest_tests.ml b/test/expect-tests/digest/digest_tests.ml
@@ -22,15 +22,15 @@ let%expect_test "directory digest version" =
     print_endline "[FAIL] unable to calculate digest");
   [%expect {| [PASS] |}]
 
-let%expect_test "reject directories with symlinks (for now)" =
+let%expect_test "directories with symlinks" =
   let dir = Temp.create Dir ~prefix:"digest-tests" ~suffix:"" in
   let stats = { Digest.Stats_for_digest.st_kind = S_DIR; st_perm = 1 } in
   let sub = Path.relative dir "sub" in
   Path.mkdir_p sub;
   Unix.symlink "bar" (Path.to_string (Path.relative dir "foo"));
   Unix.symlink "bar" (Path.to_string (Path.relative sub "foo"));
   (match Digest.path_with_stats ~allow_dirs:true dir stats with
-  | Ok _ -> print_endline "[FAIL] failure expected"
-  | Unexpected_kind -> print_endline "[PASS]"
+  | Ok _ -> print_endline "[PASS]"
+  | Unexpected_kind -> print_endline "[FAIL] unexpected kind"
   | Unix_error _ -> print_endline "[FAIL] unable to calculate digest");
   [%expect {| [PASS] |}]