Add ability to follow symlinks during recursive directory traversal

CHANGELOG.txt

@@ -1,3 +1,8 @@
+master, 2025-08-08:
+	Added ability to follow symlinks during recursive directory traversal via a new SymlinkBehavior option.
+	Moved doesDirectoryExistFast to a new System.FilePath.Glob.Internal module for better encapsulation.
+	Renamed the optimized doesDirectoryExist to doesDirectoryExistFast for clarity.
+
 0.10.2, 2021-11-10:
 	Relaxed transformers-compat version bound.
 

Glob.cabal

@@ -37,20 +37,27 @@ Library
       Build-Depends: semigroups >= 0.18
 
    if os(windows)
-      Build-Depends: Win32 >= 2
+      Build-Depends: Win32            >= 2
+   else
+      Build-Depends: unix             >= 2.7
 
    Default-Language: Haskell98
 
    Exposed-Modules: System.FilePath.Glob
                     System.FilePath.Glob.Primitive
    Other-Modules:   System.FilePath.Glob.Base
                     System.FilePath.Glob.Directory
+                    System.FilePath.Glob.Internal
                     System.FilePath.Glob.Match
                     System.FilePath.Glob.Simplify
+                    System.FilePath.Glob.Types
                     System.FilePath.Glob.Utils
+                    System.FilePath.Glob.Utils.Directory
+                    System.FilePath.Glob.Utils.IO
 
    GHC-Options: -Wall
 
+
 Test-Suite glob-tests
    type: exitcode-stdio-1.0
 
@@ -66,9 +73,11 @@ Test-Suite glob-tests
                 , transformers-compat        >= 0.3
                 , HUnit                      >= 1.2
                 , QuickCheck                 >= 2
+                , temporary                  >= 1.2
                 , test-framework             >= 0.2
                 , test-framework-hunit       >= 0.2
                 , test-framework-quickcheck2 >= 0.3
+                , unix                       >= 2.7
 
    if impl(ghc < 8.0)
       Build-Depends: semigroups >= 0.18
@@ -80,10 +89,14 @@ Test-Suite glob-tests
 
    Other-Modules: System.FilePath.Glob.Base
                   System.FilePath.Glob.Directory
+                  System.FilePath.Glob.Internal
                   System.FilePath.Glob.Match
                   System.FilePath.Glob.Primitive
                   System.FilePath.Glob.Simplify
+                  System.FilePath.Glob.Types
                   System.FilePath.Glob.Utils
+                  System.FilePath.Glob.Utils.Directory
+                  System.FilePath.Glob.Utils.IO
                   Tests.Base
                   Tests.Compiler
                   Tests.Directory
@@ -93,5 +106,7 @@ Test-Suite glob-tests
                   Tests.Regression
                   Tests.Simplifier
                   Tests.Utils
+                  Tests.Symlinks
+                  Tests.Symlinks.NoSymlinksTree
 
    GHC-Options: -Wall

System/FilePath/Glob.hs

@@ -54,6 +54,7 @@ module System.FilePath.Glob
    , MatchOptions(..)
    , matchWith
    , GlobOptions(..)
+   , SymlinkBehavior(..)
    , globDirWith
      -- **** Predefined option sets
    , matchDefault, matchPosix
@@ -77,3 +78,5 @@ import System.FilePath.Glob.Directory ( GlobOptions(..), globDefault
                                       )
 import System.FilePath.Glob.Match     (match, matchWith)
 import System.FilePath.Glob.Simplify  (simplify)
+import System.FilePath.Glob.Types     ( SymlinkBehavior(..)
+                                      )

System/FilePath/Glob/Directory.hs

@@ -25,24 +25,30 @@ import System.FilePath.Glob.Base  ( Pattern(..), Token(..)
                                   , compile
                                   )
 import System.FilePath.Glob.Match (matchWith)
-import System.FilePath.Glob.Utils ( getRecursiveContents
+import System.FilePath.Glob.Utils ( getRecursiveContentsWithSymlinks
                                   , nubOrd
                                   , pathParts
                                   , partitionDL, tailDL
-                                  , catchIO
                                   )
--- |Options which can be passed to the 'globDirWith' function.
+
+import System.FilePath.Glob.Types (SymlinkBehavior(..))
+import System.FilePath.Glob.Utils.IO (catchIO)
+
+--- |Options which can be passed to the 'globDirWith' function.
 data GlobOptions = GlobOptions
   { matchOptions :: MatchOptions
   -- ^Options controlling how matching is performed; see 'MatchOptions'.
   , includeUnmatched :: Bool
   -- ^Whether to include unmatched files in the result.
+  , symlinkBehavior :: SymlinkBehavior
+  -- ^Whether to follow symlinked directories during traversal.
+  --   Note: On Windows, following symlinks is not supported and symlinked directories will not be traversed.
   }
 
 -- |The default set of globbing options: uses the default matching options, and
 -- does not include unmatched files.
 globDefault :: GlobOptions
-globDefault = GlobOptions matchDefault False
+globDefault = GlobOptions matchDefault False DoNotFollowSymlinks
 
 -- The Patterns in TypedPattern don't contain PathSeparator or AnyDirectory
 --
@@ -127,7 +133,7 @@ globDirWith' opts []   dir =
    if includeUnmatched opts
       then do
          dir' <- if null dir then getCurrentDirectory else return dir
-         c <- getRecursiveContents dir'
+         c <- getRecursiveContentsWithSymlinks (symlinkBehavior opts) dir'
          return ([], Just (DL.toList c))
       else
          return ([], Nothing)
@@ -215,7 +221,7 @@ matchTypedAndGo opts (AnyDir n p:ps) path absPath =
 
          case unconditionalMatch || matchWith (matchOptions opts) p' path of
               True | isDir -> do
-                 contents <- getRecursiveContents absPath
+                 contents <- getRecursiveContentsWithSymlinks (symlinkBehavior opts) absPath
                  return $
                     -- foo**/ should match foo/ and nothing below it
                     -- relies on head contents == absPath
@@ -288,7 +294,7 @@ didNotMatch opts path absPath isDir =
          if isDir
             then if path `elem` [".",".."]
                     then return DL.empty
-                    else getRecursiveContents absPath
+                    else getRecursiveContentsWithSymlinks (symlinkBehavior opts) absPath
             else return$ DL.singleton absPath
       else
          return (DL.empty, DL.empty)

System/FilePath/Glob/Internal.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module System.FilePath.Glob.Internal
+   ( doesDirectoryExistFast
+   ) where
+
+#if mingw32_HOST_OS
+import Data.Bits          ((.&.))
+import System.Win32.Types (LPCTSTR, withTString)
+import System.Win32.File  (FileAttributeOrFlag, fILE_ATTRIBUTE_DIRECTORY)
+#else
+import Foreign.C.String      (withCString)
+import Foreign.Marshal.Alloc (allocaBytes)
+import System.FilePath
+   (isDrive, dropTrailingPathSeparator, addTrailingPathSeparator)
+import System.Posix.Internals (sizeof_stat, lstat, s_isdir, st_mode)
+#endif
+
+#if mingw32_HOST_OS
+foreign import stdcall unsafe "windows.h GetFileAttributesW"
+   c_GetFileAttributes :: LPCTSTR -> IO FileAttributeOrFlag
+#endif
+
+-- Significantly speedier than System.Directory.doesDirectoryExistFast.
+doesDirectoryExistFast :: FilePath -> IO Bool
+#if mingw32_HOST_OS
+-- This one allocates more memory since it has to do a UTF-16 conversion, but
+-- that can't really be helped: the below version is locale-dependent.
+doesDirectoryExistFast = flip withTString $ \s -> do
+   a <- c_GetFileAttributes s
+   return (a /= 0xffffffff && a.&.fILE_ATTRIBUTE_DIRECTORY /= 0)
+#else
+doesDirectoryExistFast s =
+   allocaBytes sizeof_stat $ \p ->
+      withCString
+         (if isDrive s
+             then addTrailingPathSeparator s
+             else dropTrailingPathSeparator s)
+         $ \c -> do
+            st <- lstat c p
+            if st == 0
+               then fmap s_isdir (st_mode p)
+               else return False
+#endif

System/FilePath/Glob/Types.hs

@@ -0,0 +1,5 @@
+module System.FilePath.Glob.Types where
+
+-- | How to handle symlinks to directories during globbing
+data SymlinkBehavior = FollowSymlinks | DoNotFollowSymlinks
+  deriving (Eq, Show)

System/FilePath/Glob/Utils.hs

@@ -11,31 +11,69 @@ module System.FilePath.Glob.Utils
    , nubOrd
    , partitionDL, tailDL
    , getRecursiveContents
-   , catchIO
+   , getRecursiveContentsWithSymlinks
    ) where
 
 import Control.Monad    (foldM)
-import qualified Control.Exception as E
 import Data.List        ((\\))
 import qualified Data.DList as DL
 import Data.DList       (DList)
 import qualified Data.Set as Set
-import System.Directory (getDirectoryContents)
+import System.Directory (getDirectoryContents, pathIsSymbolicLink)
 import System.FilePath  ((</>), isPathSeparator, dropDrive)
+import System.FilePath.Glob.Internal
+import System.FilePath.Glob.Utils.IO (catchIO)
 import System.IO.Unsafe (unsafeInterleaveIO)
 
+import System.FilePath.Glob.Utils.Directory (isDirectory)
+import System.FilePath.Glob.Types (SymlinkBehavior(..))
+
 #if mingw32_HOST_OS
 import Data.Bits          ((.&.))
 import System.Win32.Types (LPCTSTR, withTString)
 import System.Win32.File  (FileAttributeOrFlag, fILE_ATTRIBUTE_DIRECTORY)
-#else
-import Foreign.C.String      (withCString)
-import Foreign.Marshal.Alloc (allocaBytes)
-import System.FilePath
-   (isDrive, dropTrailingPathSeparator, addTrailingPathSeparator)
-import System.Posix.Internals (sizeof_stat, lstat, s_isdir, st_mode)
 #endif
 
+
+-- | Recursively list all files and directories under the given directory.
+--
+-- The traversal behavior for symlinks to directories is controlled by the
+-- 'SymlinkBehavior' argument:
+--
+--   * 'FollowSymlinks': Symlinks to directories are followed, so the traversal
+--     will recurse into them as if they were normal directories. This may result
+--     in visiting the same file or directory multiple times if there are cycles.
+--
+--   * 'DoNotFollowSymlinks': Symlinks to directories are not followed; the
+--     traversal will include the symlink itself in the result, but will not
+--     recurse into it.
+--
+-- The result is a 'DList' of all files and directories (including the root),
+-- in traversal order. The function is robust to IO errors (e.g., permission
+-- denied), returning the directory itself if it cannot be read.
+--
+-- When there are no symlinks in the directory tree, both behaviors are
+-- equivalent and produce the same result.
+--
+-- Note: On Windows, following symlinks is not supported and symlinked directories will not be traversed.
+getRecursiveContentsWithSymlinks :: SymlinkBehavior -> FilePath -> IO (DList FilePath)
+getRecursiveContentsWithSymlinks symlinkBehavior dir =
+    flip catchIO (\_ -> return $ DL.singleton dir) $ do
+         isSymDir <- pathIsSymbolicLink dir
+         let followSymlinks = symlinkBehavior == FollowSymlinks
+         if isSymDir && not followSymlinks
+            then return $ DL.singleton dir
+            else do
+               raw <- getDirectoryContents dir
+               let entries = map (dir </>) (raw \\ [".",".."])
+               entryInfos <- mapM (\e -> do
+                  isDir <- isDirectory followSymlinks e
+                  return (e, isDir)) entries
+               let (dirs,files) = ([e | (e,True) <- entryInfos], [e | (e,False) <- entryInfos])
+               subs <- unsafeInterleaveIO . mapM (getRecursiveContentsWithSymlinks symlinkBehavior) $ dirs
+               return $ DL.cons dir (DL.fromList files `DL.append` DL.concat subs)
+
+
 inRange :: Ord a => (a,a) -> a -> Bool
 inRange (a,b) c = c >= a && c <= b
 
@@ -104,28 +142,6 @@ pathParts p = p : let d = dropDrive p
          then xs : f xs
          else      f xs
 
--- Significantly speedier than System.Directory.doesDirectoryExist.
-doesDirectoryExist :: FilePath -> IO Bool
-#if mingw32_HOST_OS
--- This one allocates more memory since it has to do a UTF-16 conversion, but
--- that can't really be helped: the below version is locale-dependent.
-doesDirectoryExist = flip withTString $ \s -> do
-   a <- c_GetFileAttributes s
-   return (a /= 0xffffffff && a.&.fILE_ATTRIBUTE_DIRECTORY /= 0)
-#else
-doesDirectoryExist s =
-   allocaBytes sizeof_stat $ \p ->
-      withCString
-         (if isDrive s
-             then addTrailingPathSeparator s
-             else dropTrailingPathSeparator s)
-         $ \c -> do
-            st <- lstat c p
-            if st == 0
-               then fmap s_isdir (st_mode p)
-               else return False
-#endif
-
 #if mingw32_HOST_OS
 #if defined(i386_HOST_ARCH)
 foreign import stdcall unsafe "windows.h GetFileAttributesW" c_GetFileAttributes :: LPCTSTR -> IO FileAttributeOrFlag
@@ -136,14 +152,19 @@ foreign import ccall unsafe "windows.h GetFileAttributesW" c_GetFileAttributes :
 #endif
 #endif
 
+-- | Recursively list all files and directories, not following symlinks (legacy behavior).
 getRecursiveContents :: FilePath -> IO (DList FilePath)
-getRecursiveContents dir =
+getRecursiveContents = getRecursiveContentsWithoutSymlinks
+
+
+getRecursiveContentsWithoutSymlinks :: FilePath -> IO (DList FilePath)
+getRecursiveContentsWithoutSymlinks dir =
    flip catchIO (\_ -> return $ DL.singleton dir) $ do
 
       raw <- getDirectoryContents dir
 
       let entries = map (dir </>) (raw \\ [".",".."])
-      (dirs,files) <- partitionM doesDirectoryExist entries
+      (dirs,files) <- partitionM doesDirectoryExistFast entries
 
       subs <- unsafeInterleaveIO . mapM getRecursiveContents $ dirs
 
@@ -181,5 +202,3 @@ nubOrd = go Set.empty
          then go set xs
          else x : go (Set.insert x set) xs
 
-catchIO :: IO a -> (E.IOException -> IO a) -> IO a
-catchIO = E.catch

System/FilePath/Glob/Utils/Directory.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE CPP #-}
+
+module System.FilePath.Glob.Utils.Directory (isDirectory) where
+
+-- | Utilities for directory and symlink handling in globbing.
+
+import System.Directory (doesDirectoryExist)
+#if !mingw32_HOST_OS
+import System.Directory (pathIsSymbolicLink)
+import System.FilePath.Glob.Utils.IO (catchIO)
+import qualified System.Posix.Files as Posix
+#endif
+
+-- | Check if a path is a directory, optionally following symlinks.
+
+isDirectory :: Bool -> FilePath -> IO Bool
+#if mingw32_HOST_OS
+isDirectory _ = doesDirectoryExist
+#else
+isDirectory followSymlinks path = do
+  isSym <- pathIsSymbolicLink path
+  if isSym
+    then if followSymlinks
+      then do
+        statusResult <- (Just <$> Posix.getFileStatus path) `catchIO` (\_ -> return Nothing)
+        case statusResult of
+          Just status -> return (Posix.isDirectory status)
+          Nothing -> return False
+      else return False
+    else doesDirectoryExist path
+#endif

System/FilePath/Glob/Utils/IO.hs

@@ -0,0 +1,7 @@
+-- | Minimal IO utility functions to avoid module cycles.
+module System.FilePath.Glob.Utils.IO (catchIO) where
+
+import qualified Control.Exception as E
+
+catchIO :: IO a -> (IOError -> IO a) -> IO a
+catchIO = E.catch

tests/Main.hs

@@ -13,6 +13,7 @@ import qualified Tests.Optimizer  as Optimizer
 import qualified Tests.Regression as Regression
 import qualified Tests.Simplifier as Simplifier
 import qualified Tests.Utils      as Utils
+import qualified Tests.Symlinks  as Symlinks
 
 main :: IO ()
 main = do
@@ -33,4 +34,5 @@ tests =
    , Simplifier.tests
    , Instances.tests
    , Directory.tests
+   , Symlinks.tests
    ]