From d9636a32b9fabab8e2d378a86ee29159cfab5ccc Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Thu, 12 Mar 2026 17:46:46 +0100 Subject: [PATCH 1/2] Allow `Path.is_descendant` to work on external paths. Signed-off-by: Ambre Austen Suhamy --- otherlibs/stdune/src/path.ml | 1 + otherlibs/stdune/src/path_external.ml | 2 +- otherlibs/stdune/test/path_tests.ml | 20 ++++---------------- 3 files changed, 6 insertions(+), 17 deletions(-) diff --git a/otherlibs/stdune/src/path.ml b/otherlibs/stdune/src/path.ml index f8647e70bcd..5bedb200bc7 100644 --- a/otherlibs/stdune/src/path.ml +++ b/otherlibs/stdune/src/path.ml @@ -584,6 +584,7 @@ let is_descendant t ~of_ = match t, of_ with | In_source_tree t, In_source_tree of_ -> Source0.is_descendant t ~of_ | In_build_dir t, In_build_dir of_ -> Build.is_descendant t ~of_ + | External t, External of_ -> External.is_descendant t ~of_ | _ -> false ;; diff --git a/otherlibs/stdune/src/path_external.ml b/otherlibs/stdune/src/path_external.ml index 7b10480f1af..84e015b60c3 100644 --- a/otherlibs/stdune/src/path_external.ml +++ b/otherlibs/stdune/src/path_external.ml @@ -103,7 +103,7 @@ include ( let to_string_maybe_quoted t = String.maybe_quoted (to_string t) let is_descendant b ~of_:a = - is_root a || String.starts_with ~prefix:(to_string a ^ "/") (to_string b) + is_root a || equal a b || String.starts_with ~prefix:(to_string a ^ "/") (to_string b) ;; module Map = String.Map diff --git a/otherlibs/stdune/test/path_tests.ml b/otherlibs/stdune/test/path_tests.ml index fc24b696aba..f7a404dd23f 100644 --- a/otherlibs/stdune/test/path_tests.ml +++ b/otherlibs/stdune/test/path_tests.ml @@ -135,18 +135,12 @@ true let%expect_test _ = is_descendant (e "/foo/bar") ~of_:(e "/foo"); - [%expect - {| -false -|}] + [%expect {| true |}] ;; let%expect_test _ = is_descendant (e "/foo/bar") ~of_:(e "/foo/bar"); - [%expect - {| -false -|}] + [%expect {| true |}] ;; let%expect_test _ = @@ -159,18 +153,12 @@ false let%expect_test _ = is_descendant (e "/foo/bar/") ~of_:(e "/foo/bar"); - [%expect - {| -false -|}] + [%expect {| true |}] ;; let%expect_test _ = is_descendant (e "/foo/bar") ~of_:(e "/"); - [%expect - {| -false -|}] + [%expect {| true |}] ;; let%expect_test _ = From db10fa9989d549ebd8d8c7b2be180ab9a67d8435 Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Tue, 5 May 2026 14:32:44 +0200 Subject: [PATCH 2/2] Use the new is_descendant function in fetch, use its new reflexivity in sandbox Signed-off-by: Ambre Austen Suhamy --- src/dune_engine/sandbox.ml | 3 +-- src/dune_pkg/fetch.ml | 22 ++++------------------ 2 files changed, 5 insertions(+), 20 deletions(-) diff --git a/src/dune_engine/sandbox.ml b/src/dune_engine/sandbox.ml index dcf508d9c28..aeb8d61d208 100644 --- a/src/dune_engine/sandbox.ml +++ b/src/dune_engine/sandbox.ml @@ -238,8 +238,7 @@ let find_corrected_files (t : real) ~deps = not (* CR-soon rgrinberg: slow for no reason. to fix. *) (let path = Path.build path in - Path.Set.exists deps ~f:(fun dep -> - Path.equal dep path || Path.is_descendant path ~of_:dep)) + Path.Set.exists deps ~f:(fun dep -> Path.is_descendant path ~of_:dep)) then Some path else None with diff --git a/src/dune_pkg/fetch.ml b/src/dune_pkg/fetch.ml index 66714c5ea7e..731e799fb0c 100644 --- a/src/dune_pkg/fetch.ml +++ b/src/dune_pkg/fetch.ml @@ -247,19 +247,7 @@ let fetch_local ~checksum ~target (url, url_loc) = Unavailable (Some (User_message.make [ Pp.text "Could not unpack:"; pp ]))) ;; -let is_descendant t ~of_ = - let is_desc_e t ~of_ = - let open Path.External in - is_root of_ - || equal of_ t - || String.starts_with ~prefix:(to_string of_ ^ "/") (to_string t) - in - match t, of_ with - | Path.External t, Path.External of_ -> is_desc_e t ~of_ - | _ -> Path.is_descendant t ~of_ -;; - -(* Dune's engine cannot handle symlinks to directories and Dune's shared cache +(** Dune's engine cannot handle symlinks to directories and Dune's shared cache rejects directory targets containing symlinks (which project sources are). There are technical reasons for both limitations, but for the sake of building packages, resolving them as hardlinks is good enough. *) @@ -270,9 +258,7 @@ let resolve_symlinks_in root = let full_name = Path.to_string relative in match Fpath.follow_symlink full_name with | Error Not_a_symlink -> - Code_error.raise - "resolve_directory_symlinks_in: not a symlink" - [ "name", Dyn.string name ] + Code_error.raise "resolve_symlinks_in: not a symlink" [ "name", Dyn.string name ] | Error Max_depth_exceeded -> User_error.raise [ Pp.textf "Unable to resolve symlink %s: too many levels of symbolic links" name @@ -296,11 +282,11 @@ let resolve_symlinks_in root = indirections, something like _build/foo/../bar or _build/../outside. [Path.of_string] canonicalizes it, removing those indirections. *) let resolved = Path.of_string resolved in - if is_descendant relative ~of_:resolved + if Path.is_descendant relative ~of_:resolved then User_error.raise [ Pp.textf "Unable to resolve symlink %s, it is part of a cycle." full_name ]; - if not (is_descendant resolved ~of_:root) + if not (Path.is_descendant resolved ~of_:root) then User_error.raise [ Pp.textf