From 53e324bfee681290c87d467d54142a9c15bba387 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Fri, 3 Feb 2023 22:31:49 +0800 Subject: [PATCH] Fix failure on JFS filesystems Some filesystems always return DT_UNKNOWN for d_type, since it's non-portable. For those cases we use 'stat' to figure out the file type. Similar to: https://github.com/ggreer/the_silver_searcher/pull/37 --- lib/GHCup/Prelude/File/Posix.hs | 12 +++--- .../Posix/{Traversals.hs => Traversals.hsc} | 40 +++++++++++++++++++ .../Prelude/File/Posix/TraversalsSpec.hs | 10 ++--- 3 files changed, 51 insertions(+), 11 deletions(-) rename lib/GHCup/Prelude/File/Posix/{Traversals.hs => Traversals.hsc} (60%) diff --git a/lib/GHCup/Prelude/File/Posix.hs b/lib/GHCup/Prelude/File/Posix.hs index a4ea316..3bab560 100644 --- a/lib/GHCup/Prelude/File/Posix.hs +++ b/lib/GHCup/Prelude/File/Posix.hs @@ -279,11 +279,11 @@ removeEmptyDirectory = PD.removeDirectory -- | Create an 'Unfold' of directory contents. unfoldDirContents :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath (FD.DirType, FilePath) -unfoldDirContents = U.bracket (liftIO . openDirStream) (liftIO . closeDirStream) (Unfold step return) +unfoldDirContents = U.bracket (liftIO . openDirStreamPortable) (liftIO . closeDirStreamPortable) (Unfold step return) where {-# INLINE [0] step #-} step dirstream = do - (typ, e) <- liftIO $ readDirEnt dirstream + (typ, e) <- liftIO $ readDirEntPortable dirstream return $ if | null e -> D.Stop | "." == e -> D.Skip dirstream @@ -308,8 +308,8 @@ getDirectoryContentsRecursiveUnfold = Unfold step (\s -> return (s, Nothing, ["" step (_, Nothing, []) = return D.Stop step (topdir, Just (cdir, dirstream, finalizer), dirs) = flip onException (runIOFinalizer finalizer) $ do - (dt, f) <- liftIO $ readDirEnt dirstream - if | FD.dtUnknown == dt -> do + (dt, f) <- liftIO $ readDirEntPortable dirstream + if | f == "" -> do runIOFinalizer finalizer return $ D.Skip (topdir, Nothing, dirs) | f == "." || f == ".." @@ -323,8 +323,8 @@ getDirectoryContentsRecursiveUnfold = Unfold step (\s -> return (s, Nothing, ["" acquire dir = withRunInIO $ \run -> mask_ $ run $ do - dirstream <- liftIO $ openDirStream dir - ref <- newIOFinalizer (liftIO $ closeDirStream dirstream) + dirstream <- liftIO $ openDirStreamPortable dir + ref <- newIOFinalizer (liftIO $ closeDirStreamPortable dirstream) return (dirstream, ref) getDirectoryContentsRecursiveBFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m) diff --git a/lib/GHCup/Prelude/File/Posix/Traversals.hs b/lib/GHCup/Prelude/File/Posix/Traversals.hsc similarity index 60% rename from lib/GHCup/Prelude/File/Posix/Traversals.hs rename to lib/GHCup/Prelude/File/Posix/Traversals.hsc index f16ccb6..645ee51 100644 --- a/lib/GHCup/Prelude/File/Posix/Traversals.hs +++ b/lib/GHCup/Prelude/File/Posix/Traversals.hsc @@ -10,9 +10,20 @@ module GHCup.Prelude.File.Posix.Traversals ( -- lower-level stuff readDirEnt +, readDirEntPortable +, openDirStreamPortable +, closeDirStreamPortable , unpackDirStream +, DirStreamPortable ) where +#include +#include +#include +#include +#include +#include + #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) @@ -28,6 +39,7 @@ import Foreign.Storable import System.Posix import Foreign (alloca) import System.Posix.Internals (peekFilePath) +import System.FilePath @@ -90,3 +102,31 @@ readDirEnt (unpackDirStream -> dirp) = then return (dtUnknown, mempty) else throwErrno "readDirEnt" + +newtype DirStreamPortable = DirStreamPortable (FilePath, DirStream) + +openDirStreamPortable :: FilePath -> IO DirStreamPortable +openDirStreamPortable fp = do + dirs <- openDirStream fp + pure $ DirStreamPortable (fp, dirs) + +closeDirStreamPortable :: DirStreamPortable -> IO () +closeDirStreamPortable (DirStreamPortable (_, dirs)) = closeDirStream dirs + +readDirEntPortable :: DirStreamPortable -> IO (DirType, FilePath) +readDirEntPortable (DirStreamPortable (basedir, dirs)) = do + (dt, fp) <- readDirEnt dirs + case (dt, fp) of + (DirType #{const DT_UNKNOWN}, _) + | fp /= "" -> do + stat <- getSymbolicLinkStatus (basedir fp) + pure $ (, fp) $ if | isBlockDevice stat -> DirType #{const DT_BLK} + | isCharacterDevice stat -> DirType #{const DT_CHR} + | isDirectory stat -> DirType #{const DT_DIR} + | isNamedPipe stat -> DirType #{const DT_FIFO} + | isSymbolicLink stat -> DirType #{const DT_LNK} + | isRegularFile stat -> DirType #{const DT_REG} + | isSocket stat -> DirType #{const DT_SOCK} + | otherwise -> DirType #{const DT_UNKNOWN} + _ -> pure (dt, fp) + diff --git a/test/GHCup/Prelude/File/Posix/TraversalsSpec.hs b/test/GHCup/Prelude/File/Posix/TraversalsSpec.hs index 2cd8cfe..d33c5ef 100644 --- a/test/GHCup/Prelude/File/Posix/TraversalsSpec.hs +++ b/test/GHCup/Prelude/File/Posix/TraversalsSpec.hs @@ -24,11 +24,11 @@ spec = do -- https://github.com/haskell/ghcup-hs/issues/415 describe "GHCup.Prelude.File.Posix.Traversals" $ do it "readDirEnt" $ do - dirstream <- liftIO $ openDirStream "test/data" - (dt1, fp1) <- readDirEnt dirstream - (dt2, fp2) <- readDirEnt dirstream - (dt3, fp3) <- readDirEnt dirstream - (dt4, fp4) <- readDirEnt dirstream + dirstream <- liftIO $ openDirStreamPortable "test/data" + (dt1, fp1) <- readDirEntPortable dirstream + (dt2, fp2) <- readDirEntPortable dirstream + (dt3, fp3) <- readDirEntPortable dirstream + (dt4, fp4) <- readDirEntPortable dirstream let xs = sortOn snd [ (dt1, fp1), (dt2, fp2) , (dt3, fp3), (dt4, fp4) ]