Fix infinite recursion in project discovery on symlink cycles

src/Paket.Core/Common/Utils.fs

@@ -402,18 +402,58 @@ let inline normalizePath(path:string) =
       .Replace(dirSeparator + "." + dirSeparator, dirSeparator)
 
 let inline windowsPath (path:string) = path.Replace(Path.DirectorySeparatorChar, '\\')
+
+/// Symlink resolution for cycle detection in directory walks. Paket.Core compiles
+/// for netstandard2.0, so `FileSystemInfo.ResolveLinkTarget` (.NET 6+) is bound at
+/// run time; a runtime without it falls back to libc `realpath` on Unix.
+module private LinkResolution =
+    open System.Runtime.InteropServices
+
+    let resolveLinkTarget : Func<FileSystemInfo, bool, FileSystemInfo> option =
+        typeof<FileSystemInfo>.GetMethod("ResolveLinkTarget", [| typeof<bool> |])
+        |> Option.ofObj
+        |> Option.map (fun m -> Delegate.CreateDelegate(typeof<Func<FileSystemInfo, bool, FileSystemInfo>>, m) :?> _)
+
+    [<DllImport("libc", EntryPoint = "realpath", SetLastError = true)>]
+    extern nativeint realpath(byte[] path, [<Out>] byte[] resolved)
+
+    /// POSIX realpath into a 4096-byte buffer (>= PATH_MAX on Linux and macOS).
+    let tryRealpath (path: string) =
+        try
+            let buffer = Array.zeroCreate<byte> 4096
+            if realpath (Array.append (Text.Encoding.UTF8.GetBytes path) [| 0uy |], buffer) = IntPtr.Zero then None
+            else
+                let len = Array.IndexOf(buffer, 0uy)
+                Some (Text.Encoding.UTF8.GetString(buffer, 0, (if len < 0 then buffer.Length else len)))
+        with :? DllNotFoundException | :? EntryPointNotFoundException -> None
+
+/// Canonical (symlink-resolved) path of `dir`; `lexical` is its path if it is not a
+/// link: the parent's canonical path plus its name, or its own FullName for a walk's
+/// root. Tree walks key a visited set on it so a cyclic symlink is entered once.
+let canonicalPath lexical (dir: DirectoryInfo) =
+    match LinkResolution.resolveLinkTarget with
+    | Some resolve ->
+        match resolve.Invoke(dir, true) with
+        | null -> lexical
+        | target -> target.FullName
+    | None when isUnix -> LinkResolution.tryRealpath dir.FullName |> Option.defaultValue lexical
+    | None -> lexical
+
 /// Gets all files with the given pattern, skipping directories whose name starts with a dot
 /// (e.g. .git, .vs, .localhistory) since these are not expected to contain relevant project files
 /// and can be large or contain unrelated backup/history data (see issue #3250).
 let FindAllFiles(folder, pattern) : FileInfo [] =
-    let rec allFiles (dir: DirectoryInfo) =
+    let visited = HashSet<string>(StringComparer.Ordinal)
+    let rec allFiles canonical (dir: DirectoryInfo) =
         seq {
-            yield! dir.GetFiles(pattern, SearchOption.TopDirectoryOnly)
-            for subDir in dir.GetDirectories() do
-                if not (subDir.Name.StartsWith ".") then
-                    yield! allFiles subDir
+            if visited.Add canonical then
+                yield! dir.GetFiles(pattern, SearchOption.TopDirectoryOnly)
+                for subDir in dir.GetDirectories() do
+                    if not (subDir.Name.StartsWith ".") then
+                        yield! allFiles (canonicalPath (Path.Combine(canonical, subDir.Name)) subDir) subDir
         }
-    allFiles (DirectoryInfo(folder)) |> Seq.toArray
+    let root = DirectoryInfo folder
+    allFiles (canonicalPath root.FullName root) root |> Seq.toArray
 
 type ResolvedPackagesFolder =
     /// No "packages" folder for the current package

src/Paket.Core/PaketConfigFiles/ProjectFile.fs

@@ -1915,7 +1915,9 @@ type ProjectFile with
         let paketPath = Path.Combine(folder,Constants.PaketFilesFolderName) |> normalizePath
 
         let findAllFiles folder =
-            let rec search topLevel (di:DirectoryInfo) =
+            let visited = HashSet<string>(StringComparer.Ordinal)
+            let rec search topLevel canonical (di:DirectoryInfo) =
+                if not (visited.Add canonical) then Array.empty else
                 try
                     if verbose then
                         verbosefn "Searching %s in %s" searchPattern di.FullName
@@ -1946,13 +1948,13 @@ type ProjectFile with
                             |> not
                         with
                         | _ -> false)
-                    |> Array.collect (search false)
+                    |> Array.collect (fun sub -> search false (canonicalPath (Path.Combine(canonical, sub.Name)) sub) sub)
                     |> Array.append files
                 with
                 | _ -> Array.empty
 
-
-            search true (DirectoryInfo folder)
+            let root = DirectoryInfo folder
+            search true (canonicalPath root.FullName root) root
 
         findAllFiles folder
 

tests/Paket.Tests/Paket.Tests.fsproj

@@ -166,6 +166,7 @@
     <Compile Include="ProjectFile\LocalizationSpecs.fs" />
     <Compile Include="ProjectFile\UpdateFromNugetSpecs.fs" />
     <Compile Include="ProjectFile\ReadPropertySpecs.fs" />
+    <Compile Include="ProjectFile\SymlinkLoopSpecs.fs" />
     <Compile Include="ProjectFile\InstallForDotnetSDKSpecs.fs" />
     <Compile Include="InstallProcess\FSharpCoreRedirectsWarningSpecs.fs" />
     <Compile Include="InstallModel\FrameworkIdentifierSpecs.fs" />

tests/Paket.Tests/ProjectFile/SymlinkLoopSpecs.fs

@@ -0,0 +1,51 @@
+module Paket.ProjectFile.SymlinkLoopSpecs
+
+open System
+open System.IO
+open Paket
+open NUnit.Framework
+open FsUnit
+
+let private withTempRoot f =
+    if isWindows then Assert.Ignore "directory symlinks need elevation on Windows"
+    let root = Path.Combine(Path.GetTempPath(), "paket-symlink-" + Guid.NewGuid().ToString("N"))
+    Directory.CreateDirectory root |> ignore
+    try f root
+    finally Directory.Delete(root, true)
+
+// Regression: a cyclic directory symlink (e.g. inside a Nix `.devenv` profile)
+// used to recurse project discovery forever.
+[<Test>]
+[<Timeout(120000)>]
+let ``FindAllProjectFiles terminates on symlink cycles and finds each project once`` () =
+    withTempRoot (fun root ->
+        let loopLink = Path.Combine(root, "sub", "loop")
+        Directory.CreateDirectory(Path.Combine(root, "sub")) |> ignore
+        File.WriteAllText(Path.Combine(root, "Real.fsproj"), "<Project />")
+        SymlinkUtils.makeDirectoryLink loopLink ".."   // sub/loop -> root
+        try
+            ProjectFile.FindAllProjectFiles root
+            |> Array.filter (fun fi -> fi.Name = "Real.fsproj")
+            |> Array.length
+            |> shouldEqual 1
+        finally
+            SymlinkUtils.delete loopLink)   // so the recursive delete cannot follow it
+
+// Positive control: symlinks are still followed, and the project keeps the path it
+// was reached by.
+[<Test>]
+let ``FindAllProjectFiles follows a symlink to a directory outside the root`` () =
+    withTempRoot (fun root ->
+        let outside = Path.Combine(root, "outside")
+        let searchRoot = Path.Combine(root, "search")
+        let link = Path.Combine(searchRoot, "linked")
+        Directory.CreateDirectory outside |> ignore
+        Directory.CreateDirectory searchRoot |> ignore
+        File.WriteAllText(Path.Combine(outside, "Linked.fsproj"), "<Project />")
+        SymlinkUtils.makeDirectoryLink link outside
+        try
+            ProjectFile.FindAllProjectFiles searchRoot
+            |> Array.map (fun fi -> fi.FullName)
+            |> shouldEqual [| Path.Combine(link, "Linked.fsproj") |]
+        finally
+            SymlinkUtils.delete link)