From 7a8c64ea7bf03943a56bb0508f2e690c4e9f30ea Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Thu, 12 Mar 2026 17:46:46 +0100 Subject: [PATCH 01/10] 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 fc0bf432045..8a983b76b07 100644 --- a/otherlibs/stdune/src/path.ml +++ b/otherlibs/stdune/src/path.ml @@ -570,6 +570,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 d97509a15e6..31bc14f739a 100644 --- a/otherlibs/stdune/src/path_external.ml +++ b/otherlibs/stdune/src/path_external.ml @@ -75,7 +75,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 || 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 8352cfd6713..018cc99686c 100644 --- a/otherlibs/stdune/test/path_tests.ml +++ b/otherlibs/stdune/test/path_tests.ml @@ -129,18 +129,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 _ = @@ -153,18 +147,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 56b3c750e1b5d11b1e778232f88a4c47d1844fbc Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Thu, 12 Mar 2026 17:46:46 +0100 Subject: [PATCH 02/10] Resolve (and delete) directory symlinks in fetched sources (archive & source) Sort entries in fetch to guarantee determinism Remove the symlink resolution happening in pkg_rules as it's too complicated. The main change happening in fetch is still there. Signed-off-by: Ambre Austen Suhamy --- src/dune_pkg/fetch.ml | 145 ++++++++++++++++-- src/dune_rules/fetch_rules.ml | 1 + .../pkg/fetch-symlinks/basic-cycle.t | 27 ++++ .../pkg/fetch-symlinks/escaping-link.t | 128 ++++++++++++++++ .../pkg/fetch-symlinks/link-to-parent.t | 37 +++++ .../pkg/fetch-symlinks/valid-links.t | 37 +++++ .../pkg/source-with-directory-symlink.t | 24 ++- 7 files changed, 373 insertions(+), 26 deletions(-) create mode 100644 test/blackbox-tests/test-cases/pkg/fetch-symlinks/basic-cycle.t create mode 100644 test/blackbox-tests/test-cases/pkg/fetch-symlinks/escaping-link.t create mode 100644 test/blackbox-tests/test-cases/pkg/fetch-symlinks/link-to-parent.t create mode 100644 test/blackbox-tests/test-cases/pkg/fetch-symlinks/valid-links.t diff --git a/src/dune_pkg/fetch.ml b/src/dune_pkg/fetch.ml index b8ecd708a47..ac41ac5ee3e 100644 --- a/src/dune_pkg/fetch.ml +++ b/src/dune_pkg/fetch.ml @@ -247,6 +247,116 @@ let fetch_local ~checksum ~target (url, url_loc) = Unavailable (Some (User_message.make [ Pp.text "Could not unpack:"; pp ]))) ;; +let resolve_directory_symlinks_in root = + let follow_symlink_exn name = + match Fpath.follow_symlink name with + | Ok resolved -> Some resolved + | Error (Unix_error _) -> None + | Error Not_a_symlink -> + Code_error.raise + "resolve_directory_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 + ] + in + let cycle_error name = + User_error.raise + [ Pp.textf "Unable to resolve symlink %s, it is part of a cycle." name ] + in + let rec resolve_rec (dir : Path.t) already_seen = + match Readdir.read_directory_with_kinds (Path.to_string dir) with + | Error e -> Unix_error.Detailed.raise e + | Ok entries -> + let sorted_entries = + List.sort + ~compare:(fun (name1, _k1) (name2, _k2) -> String.compare name1 name2) + entries + in + List.fold_left sorted_entries ~init:already_seen ~f:(fun seen (name, kind) -> + let relative = Path.relative dir name in + let full_name = Path.to_string relative in + match (kind : Unix.file_kind) with + | S_DIR -> resolve_rec relative seen + | S_LNK -> + if String.Set.mem already_seen full_name then cycle_error full_name; + let seen = String.Set.add seen full_name in + (match follow_symlink_exn full_name with + | None -> + (* Delete faulty symlinks silently, as they're allowed in fetched sources. *) + Fpath.unlink_no_err full_name; + Log.info + "Deleted broken symlink from fetched archive" + [ "full_name", Dyn.string full_name ]; + seen + | Some raw_resolved -> + (* [raw_resolved] is a relative build path but it might contain indirections, + something like _build/foo/../bar + or _build/../outside *) + let canon_resolved = Path.of_string raw_resolved in + if Path.is_descendant relative ~of_:canon_resolved then cycle_error full_name; + if not (Path.is_descendant canon_resolved ~of_:root) + then + User_error.raise + [ Pp.textf + "Unable to resolve symlink %s: its target %s is outside the source \ + directory" + full_name + (Path.to_string canon_resolved) + ]; + (match Unix.stat raw_resolved with + | { Unix.st_kind = S_DIR; _ } -> + Fpath.unlink_exn full_name; + (match Fpath.mkdir_p full_name with + | `Created -> () + | `Already_exists -> + User_error.raise + [ Pp.textf + "Unable to resolve symlink %s: a directory with the same name \ + already exists." + full_name + ]); + (match + Readdir.read_directory_with_kinds (Path.to_string canon_resolved) + with + | Error e -> Unix_error.Detailed.raise e + | Ok children -> + let symlinks_in_children = + List.fold_left + children + ~init:false + ~f:(fun symlinks_in_children (child_name, child_kind) -> + let child_path = Filename.concat raw_resolved child_name in + let src = Path.of_string child_path in + let dst = + Path.of_string (Filename.concat full_name child_name) + in + match (child_kind : Unix.file_kind) with + | S_REG -> + Io.portable_hardlink ~src ~dst; + symlinks_in_children + | S_DIR -> + Io.portable_symlink ~src ~dst; + true + | S_LNK -> + follow_symlink_exn child_path + |> Option.iter ~f:(fun linked_path -> + let src = Path.of_string linked_path in + Io.portable_symlink ~src ~dst); + true + | _ -> symlinks_in_children) + in + if symlinks_in_children then resolve_rec relative seen else seen) + | _ -> + (* We do not care about symlinks pointing to anything but directories. *) + seen)) + | _ -> seen) + in + let _symlinks_seen : String.Set.t = resolve_rec root String.Set.empty in + () +;; + let fetch ~unpack ~checksum ~target ~url:(url_loc, url) = let event = Dune_trace.( @@ -265,18 +375,29 @@ let fetch ~unpack ~checksum ~target ~url:(url_loc, url) = Dune_trace.Out.finish trace event); Fiber.return ()) (fun () -> - match url.backend with - | `git -> - let* rev_store = Rev_store.get in - fetch_git rev_store ~target ~url:(url_loc, url) - | `http -> fetch_curl ~unpack ~checksum ~target url - | `rsync -> - if not unpack - then - Code_error.raise "fetch_local: unpack is not set" [ "url", OpamUrl.to_dyn url ]; - fetch_local ~checksum ~target (url, url_loc) - | `hg -> unsupported_backend "mercurial" - | `darcs -> unsupported_backend "darcs") + let+ fetch_result = + match url.backend with + | `git -> + let* rev_store = Rev_store.get in + fetch_git rev_store ~target ~url:(url_loc, url) + | `http -> fetch_curl ~unpack ~checksum ~target url + | `rsync -> + if not unpack + then + Code_error.raise + "fetch_local: unpack is not set" + [ "url", OpamUrl.to_dyn url ]; + fetch_local ~checksum ~target (url, url_loc) + | `hg -> unsupported_backend "mercurial" + | `darcs -> unsupported_backend "darcs" + in + match fetch_result with + | Ok () -> + let target_str = Path.to_string target in + if (Unix.lstat target_str).st_kind = S_DIR + then resolve_directory_symlinks_in target; + Ok () + | Error e -> Error e) ;; let fetch_without_checksum ~unpack ~target ~url = diff --git a/src/dune_rules/fetch_rules.ml b/src/dune_rules/fetch_rules.ml index b70c1ed4139..9174a6283d0 100644 --- a/src/dune_rules/fetch_rules.ml +++ b/src/dune_rules/fetch_rules.ml @@ -122,6 +122,7 @@ module Spec = struct filesystem). Broken symlinks are excluded while copying files from local directories into the build directory, and the logic for excluding them lives in [Pkg_rules.source_rules]. *) + (* CR-Ambre remove this? *) let target_abs = Path.to_absolute_filename target in let on_symlink ~dir fname () = let path = Filename.concat target_abs (Filename.concat dir fname) in diff --git a/test/blackbox-tests/test-cases/pkg/fetch-symlinks/basic-cycle.t b/test/blackbox-tests/test-cases/pkg/fetch-symlinks/basic-cycle.t new file mode 100644 index 00000000000..d33beb2ce7c --- /dev/null +++ b/test/blackbox-tests/test-cases/pkg/fetch-symlinks/basic-cycle.t @@ -0,0 +1,27 @@ +Test that we don't get pulled inside an infinite loop when 2 symlinks form a basic cycle. + + $ mkdir -p _src/dir_a + $ mkdir -p _src/dir_b + $ echo "file in a" > _src/dir_a/file_a.txt + $ echo "file in b" > _src/dir_b/file_b.txt + $ ln -s ../dir_b _src/dir_a/link_to_b + $ ln -s ../dir_a _src/dir_b/link_to_a + + $ make_lockdir + + $ tar czf _src.tar.gz _src + + $ make_lockpkg foo < (version 0.0.1) + > (source + > (fetch + > (url file://$PWD/_src.tar.gz))) + > (build (run cat file.txt)) + > EOF + +This fails correctly + $ build_pkg foo 2>&1 | sanitize_pkg_digest foo.0.0.1 | tail -3 + Error: Unable to resolve symlink + _build/_private/default/.pkg/foo.0.0.1-DIGEST_HASH/source/dir_a/link_to_b/link_to_a, + it is part of a cycle. + [1] diff --git a/test/blackbox-tests/test-cases/pkg/fetch-symlinks/escaping-link.t b/test/blackbox-tests/test-cases/pkg/fetch-symlinks/escaping-link.t new file mode 100644 index 00000000000..8d2a17b91aa --- /dev/null +++ b/test/blackbox-tests/test-cases/pkg/fetch-symlinks/escaping-link.t @@ -0,0 +1,128 @@ +Test that we don't allow symlinks to escape the project root. + +Case 1: standard relative directory link + $ mkdir _outside_sources/ + $ echo "secret" > _outside_sources/file.txt + + $ mkdir -p _src/ + $ echo "content" > _src/file.txt + $ ln -s ../_outside_sources _src/link_to_outside + + $ make_lockdir + + $ tar czf _src.tar.gz _src + +Foo tests if the package is succesfully extracted and built + $ make_lockpkg foo < (version 0.0.1) + > (source + > (fetch + > (url file://$PWD/_src.tar.gz))) + > (build (run cat file.txt)) + > EOF + +Bar tests if the symlink is still usable after extraction + $ make_lockpkg bar < (version 0.0.1) + > (source + > (fetch + > (url file://$PWD/_src.tar.gz))) + > (build (run cat link_to_outside/file.txt)) + > EOF + +This works because since the link was relative, when fetched it becomes invalid. +We then delete it silently. + $ build_pkg foo + content + + $ dune trace cat | jq 'select(.args.message == "Deleted broken symlink from fetched archive") | {args}' | sanitize_pkg_digest foo.0.0.1 + { + "args": { + "message": "Deleted broken symlink from fetched archive", + "full_name": "_build/_private/default/.pkg/foo.0.0.1-DIGEST_HASH/source/link_to_outside" + } + } + +This should fail since the symlink was deleted + $ build_pkg bar + File "dune.lock/bar.pkg", line 5, characters 12-15: + 5 | (build (run cat link_to_outside/file.txt)) + ^^^ + Error: Logs for package bar + cat: link_to_outside/file.txt: No such file or directory + + [1] + +Case 2 relative directory link that is still valid after extraction + + $ rm _src/link_to_outside + $ ln -s ../../../../../../_outside_sources _src/link_to_outside + + $ tar czf _src.tar.gz _src + +This fails correctly, the link isn't allowed to go outside + $ build_pkg foo 2>&1 | sanitize_pkg_digest foo.0.0.1 | tail -3 + Error: Unable to resolve symlink + _build/_private/default/.pkg/foo.0.0.1-DIGEST_HASH/source/link_to_outside: + its target _outside_sources is outside the source directory + [1] + +Case 3: absolute directory link + + $ rm _src/link_to_outside + $ echo "secret" > $PWD/_outside_sources/file.txt + $ ln -s $PWD/_outside_sources _src/link_to_outside + + $ tar czf _src.tar.gz _src + +This fails correctly + $ build_pkg foo 2>&1 | sanitize_pkg_digest foo.0.0.1 | tail -5 + Error: Unable to resolve symlink + _build/_private/default/.pkg/foo.0.0.1-DIGEST_HASH/source/link_to_outside: + its target + $TESTCASE_ROOT/_outside_sources + is outside the source directory + [1] + +Case 4: relative file links + + $ rm _src/link_to_outside + $ ln -s ../_outside_sources/file.txt _src/link_to_secret + + $ tar czf _src.tar.gz _src + + $ make_lockpkg bar < (version 0.0.1) + > (source + > (fetch + > (url file://$PWD/_src.tar.gz))) + > (build (run cat link_to_secret)) + > EOF + +This should either work and print 'content' or fail??? + $ build_pkg foo + +TODO: I don't even know what should happen here + $ build_pkg bar + File "dune.lock/bar.pkg", line 5, characters 12-15: + 5 | (build (run cat link_to_secret)) + ^^^ + Error: Logs for package bar + cat: link_to_secret: No such file or directory + + [1] + +Case 5: absolute file links + $ rm _src/link_to_secret + $ ln -s $PWD/_outside_sources/file.txt _src/link_to_secret + + $ tar czf _src.tar.gz _src + +This fails correctly + $ build_pkg foo 2>&1 | sanitize_pkg_digest foo.0.0.1 | tail -5 + Error: Unable to resolve symlink + _build/_private/default/.pkg/foo.0.0.1-DIGEST_HASH/source/link_to_secret: + its target + $TESTCASE_ROOT/_outside_sources/file.txt + is outside the source directory + [1] diff --git a/test/blackbox-tests/test-cases/pkg/fetch-symlinks/link-to-parent.t b/test/blackbox-tests/test-cases/pkg/fetch-symlinks/link-to-parent.t new file mode 100644 index 00000000000..62f86e73157 --- /dev/null +++ b/test/blackbox-tests/test-cases/pkg/fetch-symlinks/link-to-parent.t @@ -0,0 +1,37 @@ +Test that we don't get pulled inside an infinite loop when a link points to a parent of itself + +Case 1: relative direct parent + + $ mkdir -p _src/mydir + $ echo "content" > _src/mydir/file.txt + $ ln -s .. _src/mydir/link_to_parent + + $ tar czf _src.tar.gz _src + + $ make_lockdir + $ make_lockpkg bar < (version 0.0.1) + > (source + > (fetch + > (url file://$PWD/_src.tar.gz))) + > (build (run cat mydir/file.txt)) + > EOF + +This fails correctly + $ build_pkg bar 2>&1 | sanitize_pkg_digest bar.0.0.1 | tail -3 + Error: Unable to resolve symlink + _build/_private/default/.pkg/bar.0.0.1-DIGEST_HASH/source/mydir/link_to_parent, + it is part of a cycle. + [1] + +Case 2: relative parent outside the source directory + + $ rm _src/mydir/link_to_parent + $ ln -s ../.. _src/mydir/link_to_root + +This fails correctly + $ build_pkg bar 2>&1 | sanitize_pkg_digest bar.0.0.1 | tail -3 + Error: Unable to resolve symlink + _build/_private/default/.pkg/bar.0.0.1-DIGEST_HASH/source/mydir/link_to_parent, + it is part of a cycle. + [1] diff --git a/test/blackbox-tests/test-cases/pkg/fetch-symlinks/valid-links.t b/test/blackbox-tests/test-cases/pkg/fetch-symlinks/valid-links.t new file mode 100644 index 00000000000..0be41f59bbd --- /dev/null +++ b/test/blackbox-tests/test-cases/pkg/fetch-symlinks/valid-links.t @@ -0,0 +1,37 @@ +Test what happens when fetched archives contain valid symlinks. + +Test symlink chains: A -> B -> C where intermediate links are also symlinks. + $ mkdir -p _src/real_dir + $ echo "content" > _src/real_dir/file.txt + $ ln -s real_dir _src/link_a + $ ln -s link_a _src/link_b + $ ln -s link_b _src/link_c + + $ tar czf _src.tar.gz _src + + $ make_lockdir + $ make_lockpkg bar < (version 0.0.1) + > (source + > (fetch + > (url file://$PWD/_src.tar.gz))) + > (build (run cat real_dir/file.txt)) + > EOF + +The works as expected + $ build_pkg bar + content + + $ ls _build/_private/default/.pkg/bar.*/source | sort + link_a + link_b + link_c + real_dir + +Links are transformed into directories + $ dune_cmd stat kind _build/_private/default/.pkg/bar.*/source/link_a + directory + +And their contents are accessible + $ ls _build/_private/default/.pkg/bar.*/source/link_b + file.txt diff --git a/test/blackbox-tests/test-cases/pkg/source-with-directory-symlink.t b/test/blackbox-tests/test-cases/pkg/source-with-directory-symlink.t index 8359a004751..83116770799 100644 --- a/test/blackbox-tests/test-cases/pkg/source-with-directory-symlink.t +++ b/test/blackbox-tests/test-cases/pkg/source-with-directory-symlink.t @@ -1,7 +1,8 @@ Test that dune handles sources containing directory symlinks. -Currently, directory symlinks in sources cause failures. This could potentially -be improved by resolving the symlinks during fetch/extraction. +Currently, directory symlinks in sources cause failures. This is substantially +improved by resolving the symlinks during extraction. +The non-tarball scenario (happening in case of local pins) isn't fixed however. -------------------------------------------------------------------------------- @@ -56,13 +57,11 @@ Case 2: Tarball source containing a directory symlink. > (build (run cat real_dir/file.txt)) > EOF -CR-someday alizter: Tarball extraction preserves symlinks, but then the target -validation rejects directory symlinks. We could resolve them after extraction. +This is now fixed + + $ build_pkg bar + content - $ build_pkg bar 2>&1 | sanitize_pkg_digest bar.0.0.1 | grep -E "^Error:|S_DIR" - Error: Error trying to read targets after a rule was run: - - default/.pkg/bar.0.0.1-DIGEST_HASH/source/link_to_dir: Unexpected file kind "S_DIR" (directory) - [1] The tarball was fully extracted (including the symlink): @@ -85,10 +84,7 @@ Case 3: Downloaded tarball containing a directory symlink (with checksum). $ echo $PWD/_src.tar.gz >> fake-curls -CR-someday alizter: Same issue as Case 2, but the error occurs during checksum -validation which happens before the source is made available. +This is now fixed - $ build_pkg baz 2>&1 | sed 's/md5=[a-f0-9]*/md5=HASH/g' | grep -E "^Error:|S_DIR" - Error: Error trying to read targets after a rule was run: - - checksum/md5=HASH/dir/link_to_dir: Unexpected file kind "S_DIR" (directory) - [1] + $ build_pkg baz + content From 24b3864926519010b48f9e67eb9e590a421ed4f6 Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Mon, 20 Apr 2026 16:07:15 +0200 Subject: [PATCH 03/10] Remove superseded symlink exclusion logic from fetch_rules. The big comment explaining everything was moved to fetch. Signed-off-by: Ambre Austen Suhamy --- src/dune_pkg/fetch.ml | 9 ++++++++- src/dune_rules/fetch_rules.ml | 27 +-------------------------- src/dune_rules/pkg_rules.ml | 4 ++-- 3 files changed, 11 insertions(+), 29 deletions(-) diff --git a/src/dune_pkg/fetch.ml b/src/dune_pkg/fetch.ml index ac41ac5ee3e..bda99cddb89 100644 --- a/src/dune_pkg/fetch.ml +++ b/src/dune_pkg/fetch.ml @@ -284,7 +284,14 @@ let resolve_directory_symlinks_in root = let seen = String.Set.add seen full_name in (match follow_symlink_exn full_name with | None -> - (* Delete faulty symlinks silently, as they're allowed in fetched sources. *) + (* Delete any broken symlinks from the unpacked archive. Dune can't + handle broken symlinks in the _build directory, but some opam + package contain broken symlinks. The logic here is applied to the + contents of package source archives but not to packages whose source + is in a local directory (e.g. when a package is pinned from the + filesystem). Broken symlinks are excluded while copying files from + local directories into the build directory, and the logic for + excluding them lives in [Pkg_rules.source_rules]. *) Fpath.unlink_no_err full_name; Log.info "Deleted broken symlink from fetched archive" diff --git a/src/dune_rules/fetch_rules.ml b/src/dune_rules/fetch_rules.ml index 9174a6283d0..626117e0eaf 100644 --- a/src/dune_rules/fetch_rules.ml +++ b/src/dune_rules/fetch_rules.ml @@ -110,32 +110,7 @@ module Spec = struct ~target ~url:(loc_url, url)) >>= function - | Ok () -> - (match kind with - | `File -> () - | `Directory -> - (* Delete any broken symlinks from the unpacked archive. Dune can't - handle broken symlinks in the _build directory, but some opam - package contain broken symlinks. The logic here is applied to the - contents of package source archives but not to packages whose source - is in a local directory (e.g. when a package is pinned from the - filesystem). Broken symlinks are excluded while copying files from - local directories into the build directory, and the logic for - excluding them lives in [Pkg_rules.source_rules]. *) - (* CR-Ambre remove this? *) - let target_abs = Path.to_absolute_filename target in - let on_symlink ~dir fname () = - let path = Filename.concat target_abs (Filename.concat dir fname) in - match Unix.stat path with - | { Unix.st_kind = kind; _ } -> (), Some kind - | exception Unix.Unix_error (Unix.ENOENT, _, _) -> - Fpath.rm_rf path; - (), None - | exception Unix.Unix_error (error, syscall, arg) -> - Unix_error.Detailed.raise (Unix_error.Detailed.create error ~syscall ~arg) - in - Fpath.traverse ~init:() ~dir:target_abs ~on_symlink:(`Call on_symlink) ()); - Fiber.return () + | Ok () -> Fiber.return () | Error (Checksum_mismatch actual_checksum) -> (match checksum with | None -> diff --git a/src/dune_rules/pkg_rules.ml b/src/dune_rules/pkg_rules.ml index fa748ee79f9..7d41446345c 100644 --- a/src/dune_rules/pkg_rules.ml +++ b/src/dune_rules/pkg_rules.ml @@ -2146,8 +2146,8 @@ let source_rules (pkg : Pkg.t) = directories. Packages whose source is extracted from an archive (possibly fetched over the web) have broken symlinks explicitly deleted immediately after the archive is - extracted. This logic is implemented in the "source-fetch" - action spec in [Fetch_rules]. *) + extracted. This logic is implemented in + [Fetch.resolve_directory_symlinks]. *) source_files, rules else ( let dst = Path.Build.append_local pkg.write_paths.source_dir file in From cc17f6f925b8293de458ba1389bbb72337c0af00 Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Mon, 20 Apr 2026 20:07:09 +0200 Subject: [PATCH 04/10] Fix 'seen' accumulator not being used inside the fold Signed-off-by: Ambre Austen Suhamy --- src/dune_pkg/fetch.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/dune_pkg/fetch.ml b/src/dune_pkg/fetch.ml index bda99cddb89..4ec4bbc42fe 100644 --- a/src/dune_pkg/fetch.ml +++ b/src/dune_pkg/fetch.ml @@ -265,7 +265,7 @@ let resolve_directory_symlinks_in root = User_error.raise [ Pp.textf "Unable to resolve symlink %s, it is part of a cycle." name ] in - let rec resolve_rec (dir : Path.t) already_seen = + let rec resolve_rec dir seen = match Readdir.read_directory_with_kinds (Path.to_string dir) with | Error e -> Unix_error.Detailed.raise e | Ok entries -> @@ -274,13 +274,13 @@ let resolve_directory_symlinks_in root = ~compare:(fun (name1, _k1) (name2, _k2) -> String.compare name1 name2) entries in - List.fold_left sorted_entries ~init:already_seen ~f:(fun seen (name, kind) -> + List.fold_left sorted_entries ~init:seen ~f:(fun seen (name, kind) -> let relative = Path.relative dir name in let full_name = Path.to_string relative in match (kind : Unix.file_kind) with | S_DIR -> resolve_rec relative seen | S_LNK -> - if String.Set.mem already_seen full_name then cycle_error full_name; + if String.Set.mem seen full_name then cycle_error full_name; let seen = String.Set.add seen full_name in (match follow_symlink_exn full_name with | None -> From f3acbc368f8631a966933ae3d973328be0ff4a0e Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Wed, 22 Apr 2026 12:17:59 +0200 Subject: [PATCH 05/10] Cleanup test cases Signed-off-by: Ambre Austen Suhamy --- .../pkg/fetch-symlinks/escaping-link.t | 26 +++++++++++++------ .../pkg/fetch-symlinks/link-to-parent.t | 3 ++- .../pkg/fetch-symlinks/valid-links.t | 2 +- 3 files changed, 21 insertions(+), 10 deletions(-) diff --git a/test/blackbox-tests/test-cases/pkg/fetch-symlinks/escaping-link.t b/test/blackbox-tests/test-cases/pkg/fetch-symlinks/escaping-link.t index 8d2a17b91aa..59cc155ade0 100644 --- a/test/blackbox-tests/test-cases/pkg/fetch-symlinks/escaping-link.t +++ b/test/blackbox-tests/test-cases/pkg/fetch-symlinks/escaping-link.t @@ -8,11 +8,11 @@ Case 1: standard relative directory link $ echo "content" > _src/file.txt $ ln -s ../_outside_sources _src/link_to_outside - $ make_lockdir - $ tar czf _src.tar.gz _src -Foo tests if the package is succesfully extracted and built + $ make_lockdir + +Foo tests if the package is successfully extracted and built $ make_lockpkg foo < (version 0.0.1) > (source @@ -43,8 +43,8 @@ We then delete it silently. } } -This should fail since the symlink was deleted - $ build_pkg bar +This fails correctly because the symlink was deleted + $ build_pkg bar 2>&1 | dune_cmd subst '/[^ ]*/cat:' 'cat:' File "dune.lock/bar.pkg", line 5, characters 12-15: 5 | (build (run cat link_to_outside/file.txt)) ^^^ @@ -99,11 +99,21 @@ Case 4: relative file links > (build (run cat link_to_secret)) > EOF -This should either work and print 'content' or fail??? +This works silently because since the symlink was deleted, we have the exact +same file system contents as case 1, hence the build is a cache hit. +The symlink is correctly deleted because it goes outside the sources. $ build_pkg foo -TODO: I don't even know what should happen here - $ build_pkg bar + $ dune trace cat | jq 'select(.args.message == "Deleted broken symlink from fetched archive") | {args}' | sanitize_pkg_digest foo.0.0.1 + { + "args": { + "message": "Deleted broken symlink from fetched archive", + "full_name": "_build/_private/default/.pkg/foo.0.0.1-DIGEST_HASH/source/link_to_secret" + } + } + +This fails correctly because the symlink was deleted + $ build_pkg bar 2>&1 | dune_cmd subst '/[^ ]*/cat:' 'cat:' File "dune.lock/bar.pkg", line 5, characters 12-15: 5 | (build (run cat link_to_secret)) ^^^ diff --git a/test/blackbox-tests/test-cases/pkg/fetch-symlinks/link-to-parent.t b/test/blackbox-tests/test-cases/pkg/fetch-symlinks/link-to-parent.t index 62f86e73157..1eea94aa406 100644 --- a/test/blackbox-tests/test-cases/pkg/fetch-symlinks/link-to-parent.t +++ b/test/blackbox-tests/test-cases/pkg/fetch-symlinks/link-to-parent.t @@ -27,7 +27,8 @@ This fails correctly Case 2: relative parent outside the source directory $ rm _src/mydir/link_to_parent - $ ln -s ../.. _src/mydir/link_to_root + $ ln -s ../.. _src/mydir/link_to_parent + $ tar czf _src.tar.gz _src This fails correctly $ build_pkg bar 2>&1 | sanitize_pkg_digest bar.0.0.1 | tail -3 diff --git a/test/blackbox-tests/test-cases/pkg/fetch-symlinks/valid-links.t b/test/blackbox-tests/test-cases/pkg/fetch-symlinks/valid-links.t index 0be41f59bbd..e8629061bf3 100644 --- a/test/blackbox-tests/test-cases/pkg/fetch-symlinks/valid-links.t +++ b/test/blackbox-tests/test-cases/pkg/fetch-symlinks/valid-links.t @@ -18,7 +18,7 @@ Test symlink chains: A -> B -> C where intermediate links are also symlinks. > (build (run cat real_dir/file.txt)) > EOF -The works as expected +This works as expected $ build_pkg bar content From 7c8dec1534b3b290ea3e05e59ff28a69ceecaef3 Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Wed, 22 Apr 2026 18:09:06 +0200 Subject: [PATCH 06/10] Enshrine in test case that the git pin workflow is also fixed Signed-off-by: Ambre Austen Suhamy --- .../pkg/source-with-directory-symlink.t | 32 +++++++++++++++++-- 1 file changed, 29 insertions(+), 3 deletions(-) diff --git a/test/blackbox-tests/test-cases/pkg/source-with-directory-symlink.t b/test/blackbox-tests/test-cases/pkg/source-with-directory-symlink.t index 83116770799..a315e116ab1 100644 --- a/test/blackbox-tests/test-cases/pkg/source-with-directory-symlink.t +++ b/test/blackbox-tests/test-cases/pkg/source-with-directory-symlink.t @@ -58,13 +58,11 @@ Case 2: Tarball source containing a directory symlink. > EOF This is now fixed - $ build_pkg bar content The tarball was fully extracted (including the symlink): - $ ls _build/_private/default/.pkg/bar.*/source link_to_dir real_dir @@ -85,6 +83,34 @@ Case 3: Downloaded tarball containing a directory symlink (with checksum). $ echo $PWD/_src.tar.gz >> fake-curls This is now fixed - $ build_pkg baz content + +-------------------------------------------------------------------------------- + +Case 4: Git pinned sources + + $ mkdir -p _src_git/real_dir + $ cd _src_git/ + $ echo "content" > real_dir/file.txt + $ ln -s real_dir link_to_dir + + $ git init --quiet + $ echo 'opam-version: "2.0"' > qux.opam + $ git add -A + $ git commit --quiet -m "Initial commit" + + $ cd .. + + $ make_lockpkg qux << EOF + > (version 0.0.1) + > (source + > (fetch + > (url git+file://$PWD/_src_git))) + > (build (run cat link_to_dir/file.txt)) + > EOF + +This is also fixed + $ build_pkg qux + content + From 3c09deac32407400a10540d0c9e5fd0edcff2941 Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Mon, 27 Apr 2026 18:00:00 +0200 Subject: [PATCH 07/10] Added inline tests to resolve_directory_symlinks as it's a complicated function Signed-off-by: Ambre Austen Suhamy --- otherlibs/stdune/src/fpath.ml | 10 ++ otherlibs/stdune/src/fpath.mli | 1 + src/dune_pkg/dune | 3 + src/dune_pkg/fetch.ml | 236 +++++++++++++++++++++++++++++++++ 4 files changed, 250 insertions(+) diff --git a/otherlibs/stdune/src/fpath.ml b/otherlibs/stdune/src/fpath.ml index 91c1c837aab..86900506cd8 100644 --- a/otherlibs/stdune/src/fpath.ml +++ b/otherlibs/stdune/src/fpath.ml @@ -257,6 +257,7 @@ let traverse ?(on_symlink = `Resolve) ?(enter_dir = fun ~dir:_ _fname -> true) ?(on_error = `Raise) + ?(sort_entries = false) () = let on_other = @@ -300,6 +301,15 @@ let traverse let acc = on_error ~dir e acc in loop root dirs acc | Ok entries -> + let entries = + if sort_entries + then + List.sort + ~compare:(fun (name1, _kind1) (name2, _kind2) -> + String.compare name2 name1) + entries + else entries + in let stack, acc = List.fold_left entries ~init:(dirs, acc) ~f:(fun (stack, acc) (fname, kind) -> match (kind : Unix.file_kind) with diff --git a/otherlibs/stdune/src/fpath.mli b/otherlibs/stdune/src/fpath.mli index faa2b902763..454fa83d41c 100644 --- a/otherlibs/stdune/src/fpath.mli +++ b/otherlibs/stdune/src/fpath.mli @@ -76,6 +76,7 @@ val traverse -> ?enter_dir:(dir:string -> Filename.t -> bool) -> ?on_error: [ `Ignore | `Raise | `Call of dir:string -> Unix_error.Detailed.t -> 'acc -> 'acc ] + -> ?sort_entries:bool -> unit -> 'acc diff --git a/src/dune_pkg/dune b/src/dune_pkg/dune index 079fad974c5..0c36706e300 100644 --- a/src/dune_pkg/dune +++ b/src/dune_pkg/dune @@ -4,6 +4,9 @@ (foreign_stubs (names md5_stubs) (language c)) + (inline_tests) + (preprocess + (pps ppx_expect)) (libraries stdune lmdb diff --git a/src/dune_pkg/fetch.ml b/src/dune_pkg/fetch.ml index 4ec4bbc42fe..9b0bfe2aee0 100644 --- a/src/dune_pkg/fetch.ml +++ b/src/dune_pkg/fetch.ml @@ -414,3 +414,239 @@ let fetch_without_checksum ~unpack ~target ~url = | Error (Checksum_mismatch _) -> assert false | Error (Unavailable message) -> Error message ;; + +let%test_module "resolve symlink tests" = + (module struct + let () = + Printexc.record_backtrace true; + Path.set_root (Path.External.cwd ()); + Path.Build.set_build_dir (Path.Outside_build_dir.of_string "_build"); + Log.init No_log_file + ;; + + (** Prints the directory tree rooted at [root] in sorted order. + - files: "path [file]" + - hardlinks: "path [hardlink]" for the first occurrence, + "path [hardlink of p1, p2, ...]" for subsequent ones sharing the same inode + - directories: "path/ [dir]" + - symlinks: "path [symlink -> target]" (not entered) + - other (pipes, sockets, etc.): "path [kind]" *) + let dump_tree root = + let str ~dir fname = + let dir = if String.is_empty dir then root else Path.relative root dir in + Path.to_string (Path.relative dir fname) + in + let inodes = Table.create (module Int) 16 in + Fpath.traverse + ~dir:(Path.to_string root) + ~init:() + ~sort_entries:true + ~on_file:(fun ~dir fname () -> + let s = str ~dir fname in + match Path.lstat (Path.of_string s) with + | Error _ -> printfn "%s [file]" s + | Ok { st_nlink; st_ino; _ } -> + if st_nlink <= 1 + then printfn "%s [file]" s + else ( + let peers = Table.find inodes st_ino |> Option.value ~default:[] in + Table.set inodes st_ino (s :: peers); + match List.rev peers with + | [] -> printfn "%s [hardlink]" s + | others -> printfn "%s [hardlink of %s]" s (String.concat ~sep:", " others))) + ~on_dir:(fun ~dir fname () -> printfn "%s/ [dir]" (str ~dir fname)) + ~on_symlink: + (`Call + (fun ~dir fname () -> + let s = str ~dir fname in + printfn "%s [symlink -> %s]" s (Unix.readlink s); + (), None)) + ~on_other: + (`Call + (fun ~dir fname kind () -> + printfn "%s [%s]" (str ~dir fname) (File_kind.to_string_hum kind))) + () + ;; + + (* [with_temp_dir name f] creates a temp directory, runs [f dir] which + should return a string (use [%expect.output] to capture printed output). + The temp dir path is replaced with [name] in the output before printing. + User_error exceptions are caught and their message is printed (also + censored). This allows [%expect] blocks to match against stable output. *) + let with_temp_dir name f = + Temp.with_temp_dir + ~parent_dir:(Path.of_string ".") + ~prefix:"symlink" + ~suffix:"test" + ~f:(function + | Error e -> raise e + | Ok dir -> + let s = + match f dir with + | s -> s + | exception User_error.E msg -> + User_message.pp msg |> Format.asprintf "%a" Pp.to_fmt + in + Re.replace_string (Re.compile (Re.str (Path.to_string dir))) ~by:name s + |> print_string) + ;; + + let make_dir dir name = Path.mkdir_p (Path.relative dir name) + let make_file dir name = Io.write_file (Path.relative dir name) name + + let make_symlink dir ~src ~dst = + Unix.symlink src (Path.to_string (Path.relative dir dst)) + ;; + + let%expect_test "no symlink no change" = + with_temp_dir "somedir" (fun dir -> + make_dir dir "real_dir"; + make_dir dir "other_dir"; + make_file dir "real_dir/file2.txt"; + make_file dir "other_dir/file1.txt"; + printfn "before"; + dump_tree dir; + resolve_directory_symlinks_in dir; + printfn "\nafter"; + dump_tree dir; + [%expect.output]); + [%expect + {| + before + somedir/real_dir/ [dir] + somedir/other_dir/ [dir] + somedir/other_dir/file1.txt [file] + somedir/real_dir/file2.txt [file] + + after + somedir/real_dir/ [dir] + somedir/other_dir/ [dir] + somedir/other_dir/file1.txt [file] + somedir/real_dir/file2.txt [file] + |}] + ;; + + let%expect_test "nested directory symlinks resolved recursively" = + with_temp_dir "$DIR" (fun dir -> + make_dir dir "real_dir"; + make_dir dir "real_dir/sub"; + make_file dir "real_dir/sub/deep.txt"; + make_symlink dir ~src:"real_dir" ~dst:"link"; + resolve_directory_symlinks_in dir; + dump_tree dir; + [%expect.output]); + [%expect + {| + $DIR/real_dir/ [dir] + $DIR/link/ [dir] + $DIR/link/sub/ [dir] + $DIR/link/sub/deep.txt [hardlink] + $DIR/real_dir/sub/ [dir] + $DIR/real_dir/sub/deep.txt [hardlink of $DIR/link/sub/deep.txt] + |}] + ;; + + let%expect_test "outside test" = + with_temp_dir "$OUTSIDE" (fun outside -> + with_temp_dir "$DIR" (fun dir -> + make_symlink dir ~src:(Path.reach ~from:dir outside) ~dst:"escape"; + resolve_directory_symlinks_in dir; + [%expect.output]); + [%expect.output]); + [%expect + {| + Error: Unable to resolve symlink $DIR/escape: its target + $OUTSIDE is outside the source directory + |}] + ;; + + let%expect_test "file symlinks" = + with_temp_dir "$DIR" (fun dir -> + make_file dir "file.txt"; + make_symlink dir ~src:"file.txt" ~dst:"link"; + resolve_directory_symlinks_in dir; + dump_tree dir; + [%expect.output]); + [%expect + {| + $DIR/link [symlink -> file.txt] + $DIR/file.txt [file] + |}] + ;; + + let%expect_test "broken symlinks deleted" = + with_temp_dir "$DIR" (fun dir -> + make_file dir "keep.txt"; + make_symlink dir ~src:"nonexistent" ~dst:"broken_link"; + (* Todo-ambre: read the log for the deletion message *) + resolve_directory_symlinks_in dir; + dump_tree dir; + [%expect.output]); + [%expect {| $DIR/keep.txt [file] |}] + ;; + + let%expect_test "cycle" = + with_temp_dir "$DIR" (fun dir -> + make_dir dir "dir_a"; + make_dir dir "dir_b"; + make_file dir "dir_a/file.txt"; + make_file dir "dir_b/file.txt"; + make_symlink dir ~src:"../dir_b" ~dst:"dir_a/link_to_b"; + make_symlink dir ~src:"../dir_a" ~dst:"dir_b/link_to_a"; + resolve_directory_symlinks_in dir; + [%expect.output]); + [%expect + {| + Error: Unable to resolve symlink + $DIR/dir_a/link_to_b/link_to_a, it is part of a cycle. + |}] + ;; + + let%expect_test "nested file link" = + with_temp_dir "$DIR" (fun dir -> + make_dir dir "target_dir"; + make_file dir "target_dir/file.txt"; + make_dir dir "real_dir"; + make_file dir "real_dir/regular.txt"; + make_symlink dir ~src:"../target_dir/file.txt" ~dst:"real_dir/inner_link"; + make_symlink dir ~src:"real_dir" ~dst:"link"; + resolve_directory_symlinks_in dir; + dump_tree dir; + [%expect.output]); + [%expect + {| + $DIR/target_dir/ [dir] + $DIR/real_dir/ [dir] + $DIR/link/ [dir] + $DIR/link/regular.txt [hardlink] + $DIR/link/inner_link [symlink -> ../target_dir/file.txt] + $DIR/real_dir/regular.txt [hardlink of $DIR/link/regular.txt] + $DIR/real_dir/inner_link [symlink -> ../target_dir/file.txt] + $DIR/target_dir/file.txt [file] + |}] + ;; + + let%expect_test "pipes?" = + with_temp_dir "$DIR" (fun dir -> + make_dir dir "real_dir"; + make_file dir "real_dir/file.txt"; + (* Pipes aren't copied! *) + Unix.mkfifo (Path.to_string (Path.relative dir "real_dir/my_pipe")) 0o644; + make_symlink dir ~src:"my_pipe" ~dst:"real_dir/pipelink"; + make_symlink dir ~src:"real_dir" ~dst:"link"; + resolve_directory_symlinks_in dir; + dump_tree dir; + [%expect.output]); + [%expect + {| + $DIR/real_dir/ [dir] + $DIR/link/ [dir] + $DIR/link/pipelink [symlink -> ../real_dir/my_pipe] + $DIR/link/file.txt [hardlink] + $DIR/real_dir/pipelink [symlink -> my_pipe] + $DIR/real_dir/my_pipe [named pipe] + $DIR/real_dir/file.txt [hardlink of $DIR/link/file.txt] + |}] + ;; + end) +;; From cafeb8be90a881f0afcec3fe112e61150c480bf9 Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Tue, 28 Apr 2026 18:55:55 +0200 Subject: [PATCH 08/10] Use Fpath.traverse in place of doing the traversal manually Remove 'seen' as cycle detection, is_descendant is enough Signed-off-by: Ambre Austen Suhamy --- src/dune_pkg/fetch.ml | 172 ++++++++++++++++-------------------------- 1 file changed, 67 insertions(+), 105 deletions(-) diff --git a/src/dune_pkg/fetch.ml b/src/dune_pkg/fetch.ml index 9b0bfe2aee0..294caa9849c 100644 --- a/src/dune_pkg/fetch.ml +++ b/src/dune_pkg/fetch.ml @@ -248,10 +248,10 @@ let fetch_local ~checksum ~target (url, url_loc) = ;; let resolve_directory_symlinks_in root = - let follow_symlink_exn name = - match Fpath.follow_symlink name with - | Ok resolved -> Some resolved - | Error (Unix_error _) -> None + let on_symlink ~dir:raw_dir name () = + let relative = Path.relative (Path.relative root raw_dir) name in + 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" @@ -260,108 +260,70 @@ let resolve_directory_symlinks_in root = User_error.raise [ Pp.textf "Unable to resolve symlink %s: too many levels of symbolic links" name ] + | Error (Unix_error _) -> + (* Delete any broken symlinks from the unpacked archive. Dune can't + handle broken symlinks in the _build directory, but some opam + package contain broken symlinks. The logic here is applied to the + contents of package source archives but not to packages whose source + is in a local directory (e.g. when a package is pinned from the + filesystem). Broken symlinks are excluded while copying files from + local directories into the build directory, and the logic for + excluding them lives in [Pkg_rules.source_rules]. *) + Fpath.unlink_no_err full_name; + Log.info + "Deleted broken symlink from fetched archive" + [ "full_name", Dyn.string full_name ]; + (), None + | Ok resolved -> + (* [resolved] is a relative build path but it might contain + 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 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 (Path.is_descendant resolved ~of_:root) + then + User_error.raise + [ Pp.textf + "Unable to resolve symlink %s: its target %s is outside the source \ + directory" + full_name + (Path.to_string resolved) + ]; + (match Unix.stat (Path.to_string resolved) with + | { Unix.st_kind = S_DIR; _ } -> + Fpath.unlink_exn full_name; + let _ : Fpath.mkdir_p_result = Fpath.mkdir_p full_name in + (match Readdir.read_directory_with_kinds (Path.to_string resolved) with + | Error e -> Unix_error.Detailed.raise e + | Ok children -> + List.iter children ~f:(fun (child_name, child_kind) -> + let src = Path.relative resolved child_name in + let dst = Path.relative relative child_name in + match (child_kind : Unix.file_kind) with + | S_REG -> Io.portable_hardlink ~src ~dst + (* TODO-ambre: add comment explaining that these symlinks will get resolved one step down *) + | S_DIR -> Io.portable_symlink ~src ~dst + | S_LNK -> + Fpath.follow_symlink (Path.to_string src) + |> Result.iter ~f:(fun linked_path -> + let src = Path.of_string linked_path in + Io.portable_symlink ~src ~dst) + | _ -> ()); + (), Some Unix.S_DIR) + | _ -> + (* We do not care about symlinks pointing to anything but directories. *) + (), None) in - let cycle_error name = - User_error.raise - [ Pp.textf "Unable to resolve symlink %s, it is part of a cycle." name ] - in - let rec resolve_rec dir seen = - match Readdir.read_directory_with_kinds (Path.to_string dir) with - | Error e -> Unix_error.Detailed.raise e - | Ok entries -> - let sorted_entries = - List.sort - ~compare:(fun (name1, _k1) (name2, _k2) -> String.compare name1 name2) - entries - in - List.fold_left sorted_entries ~init:seen ~f:(fun seen (name, kind) -> - let relative = Path.relative dir name in - let full_name = Path.to_string relative in - match (kind : Unix.file_kind) with - | S_DIR -> resolve_rec relative seen - | S_LNK -> - if String.Set.mem seen full_name then cycle_error full_name; - let seen = String.Set.add seen full_name in - (match follow_symlink_exn full_name with - | None -> - (* Delete any broken symlinks from the unpacked archive. Dune can't - handle broken symlinks in the _build directory, but some opam - package contain broken symlinks. The logic here is applied to the - contents of package source archives but not to packages whose source - is in a local directory (e.g. when a package is pinned from the - filesystem). Broken symlinks are excluded while copying files from - local directories into the build directory, and the logic for - excluding them lives in [Pkg_rules.source_rules]. *) - Fpath.unlink_no_err full_name; - Log.info - "Deleted broken symlink from fetched archive" - [ "full_name", Dyn.string full_name ]; - seen - | Some raw_resolved -> - (* [raw_resolved] is a relative build path but it might contain indirections, - something like _build/foo/../bar - or _build/../outside *) - let canon_resolved = Path.of_string raw_resolved in - if Path.is_descendant relative ~of_:canon_resolved then cycle_error full_name; - if not (Path.is_descendant canon_resolved ~of_:root) - then - User_error.raise - [ Pp.textf - "Unable to resolve symlink %s: its target %s is outside the source \ - directory" - full_name - (Path.to_string canon_resolved) - ]; - (match Unix.stat raw_resolved with - | { Unix.st_kind = S_DIR; _ } -> - Fpath.unlink_exn full_name; - (match Fpath.mkdir_p full_name with - | `Created -> () - | `Already_exists -> - User_error.raise - [ Pp.textf - "Unable to resolve symlink %s: a directory with the same name \ - already exists." - full_name - ]); - (match - Readdir.read_directory_with_kinds (Path.to_string canon_resolved) - with - | Error e -> Unix_error.Detailed.raise e - | Ok children -> - let symlinks_in_children = - List.fold_left - children - ~init:false - ~f:(fun symlinks_in_children (child_name, child_kind) -> - let child_path = Filename.concat raw_resolved child_name in - let src = Path.of_string child_path in - let dst = - Path.of_string (Filename.concat full_name child_name) - in - match (child_kind : Unix.file_kind) with - | S_REG -> - Io.portable_hardlink ~src ~dst; - symlinks_in_children - | S_DIR -> - Io.portable_symlink ~src ~dst; - true - | S_LNK -> - follow_symlink_exn child_path - |> Option.iter ~f:(fun linked_path -> - let src = Path.of_string linked_path in - Io.portable_symlink ~src ~dst); - true - | _ -> symlinks_in_children) - in - if symlinks_in_children then resolve_rec relative seen else seen) - | _ -> - (* We do not care about symlinks pointing to anything but directories. *) - seen)) - | _ -> seen) - in - let _symlinks_seen : String.Set.t = resolve_rec root String.Set.empty in - () + Fpath.traverse + ~dir:(Path.to_string root) + ~init:() + ~on_symlink:(`Call on_symlink) + ~on_other:`Ignore + ~sort_entries:true + () ;; let fetch ~unpack ~checksum ~target ~url:(url_loc, url) = From b6df243b4aa83e056bdb053108ac770abe780eb5 Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Wed, 29 Apr 2026 18:04:32 +0200 Subject: [PATCH 09/10] Added comments Signed-off-by: Ambre Austen Suhamy --- src/dune_pkg/fetch.ml | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/dune_pkg/fetch.ml b/src/dune_pkg/fetch.ml index 294caa9849c..22fd13b71c9 100644 --- a/src/dune_pkg/fetch.ml +++ b/src/dune_pkg/fetch.ml @@ -247,6 +247,8 @@ let fetch_local ~checksum ~target (url, url_loc) = Unavailable (Some (User_message.make [ Pp.text "Could not unpack:"; pp ]))) ;; +(* Dune can't handle symbolic links pointing to directories, so we replace them + with regular directories containing the same contents. *) let resolve_directory_symlinks_in root = let on_symlink ~dir:raw_dir name () = let relative = Path.relative (Path.relative root raw_dir) name in @@ -304,7 +306,8 @@ let resolve_directory_symlinks_in root = let dst = Path.relative relative child_name in match (child_kind : Unix.file_kind) with | S_REG -> Io.portable_hardlink ~src ~dst - (* TODO-ambre: add comment explaining that these symlinks will get resolved one step down *) + (* To avoid recursing here, we create symlinks will get resolved + one step down in [traverse]. *) | S_DIR -> Io.portable_symlink ~src ~dst | S_LNK -> Fpath.follow_symlink (Path.to_string src) @@ -540,7 +543,7 @@ let%test_module "resolve symlink tests" = with_temp_dir "$DIR" (fun dir -> make_file dir "keep.txt"; make_symlink dir ~src:"nonexistent" ~dst:"broken_link"; - (* Todo-ambre: read the log for the deletion message *) + (* We could check the log here to check the message. *) resolve_directory_symlinks_in dir; dump_tree dir; [%expect.output]); From ee52e3b0a967280c4d6ca257403575cb1714063b Mon Sep 17 00:00:00 2001 From: Ali Caglayan Date: Wed, 29 Apr 2026 22:08:30 +0200 Subject: [PATCH 10/10] fix: add -inline-test-allow-let-test-module for OxCaml compat Signed-off-by: Ali Caglayan --- src/dune_pkg/dune | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/src/dune_pkg/dune b/src/dune_pkg/dune index 0c36706e300..bd4a8b08090 100644 --- a/src/dune_pkg/dune +++ b/src/dune_pkg/dune @@ -1,3 +1,19 @@ +; OxCaml's ppx_expect v0.18 rejects [let%test_module] in favour of +; [module%test], but upstream ppx_expect has not released v0.18 yet. +; Until it does we must support both: pass the compatibility flag on +; OxCaml and nothing otherwise. + +(rule + (enabled_if %{ocaml-config:ox}) + (action + (write-file ppx-extra-flags "-inline-test-allow-let-test-module"))) + +(rule + (enabled_if + (not %{ocaml-config:ox})) + (action + (write-file ppx-extra-flags ""))) + (library (name dune_pkg) (synopsis "[Internal] Dune's packaging support") @@ -6,7 +22,7 @@ (language c)) (inline_tests) (preprocess - (pps ppx_expect)) + (pps ppx_expect -- %{read-lines:ppx-extra-flags})) (libraries stdune lmdb