diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,7 +1,15 @@ +# 0.2 + +– New function for listing directory contents recursively ‘getDirectoryContentsRecursive’ +- New function for defining custom recursive directory traversals ‘listContentsRecFold’ +- ‘readDirStream’ now returns file type in addition to basename +- ‘DirStream’ is now safe to close multiple times and it will be automatically closed by GC when it becomes unreachable +- The ‘FileType’ type now has only 3 constructors, symlink status is now field of some of them + # 0.1.0.3 - Lower `base` minimum required base to 4.12 (GHC 8.6). Minimum - supported `unix` is still 2.8 because of `OsString`. + supported `unix` is still 2.8 because of `OsString` # 0.1.0.2 diff --git a/Readme.md b/Readme.md --- a/Readme.md +++ b/Readme.md @@ -7,4 +7,6 @@ perspective, this reading interface allows stopping at any point without loading every directory element. +Also defines general-purpose recursive directory traversals. + Both Windows and Unix systems are supported. diff --git a/directory-ospath-streaming.cabal b/directory-ospath-streaming.cabal --- a/directory-ospath-streaming.cabal +++ b/directory-ospath-streaming.cabal @@ -5,7 +5,7 @@ name: directory-ospath-streaming version: - 0.1.0.3 + 0.2 synopsis: Stream directory entries in constant memory in vanilla IO description: @@ -14,6 +14,8 @@ perspective, this reading interface allows stopping at any point without loading every directory element. + Also defines general-purpose recursive directory traversals. + Both Windows and Unix systems are supported. copyright: (c) Sergey Vinokurov 2023 @@ -97,7 +99,6 @@ -Wno-missing-role-annotations -Wno-missing-poly-kind-signatures - common depends-on-filepath if flag(os-string) build-depends: @@ -110,21 +111,27 @@ library import: ghc-options, depends-on-filepath exposed-modules: - System.Directory.OsPath.FileType System.Directory.OsPath.Streaming + System.Directory.OsPath.Streaming.Internal + System.Directory.OsPath.Streaming.Internal.Raw + System.Directory.OsPath.Types + other-modules: + System.Directory.OsPath.Contents + System.Directory.OsPath.FileType hs-source-dirs: src build-depends: + , atomic-counter , base >= 4.12 && < 5 + , deepseq >= 1.4 if os(windows) build-depends: - , atomic-counter , directory >= 1.3.8 , Win32 >= 2.13.3 else - -- Cannot use lower version because it doesn’t support OsStrings build-depends: + -- Cannot use lower version because it doesn’t support OsStrings , unix >= 2.8 test-suite test diff --git a/src/System/Directory/OsPath/Contents.hs b/src/System/Directory/OsPath/Contents.hs new file mode 100644 --- /dev/null +++ b/src/System/Directory/OsPath/Contents.hs @@ -0,0 +1,169 @@ +-- | +-- Module: System.Directory.OsPath.Contents +-- Copyright: (c) Sergey Vinokurov 2024 +-- License: Apache-2.0 (see LICENSE) +-- Maintainer: serg.foo@gmail.com + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module System.Directory.OsPath.Contents + ( getDirectoryContentsRecursive + + , listContentsRecFold + ) where + +import Control.Exception (mask, onException) +import Data.Coerce (coerce, Coercible) +import System.IO.Unsafe (unsafeInterleaveIO) +import System.OsPath + +import System.Directory.OsPath.Streaming.Internal (DirStream) +import qualified System.Directory.OsPath.Streaming.Internal as Streaming +import qualified System.Directory.OsPath.Streaming.Internal.Raw as Raw +import System.Directory.OsPath.Types + +-- | Recursively list all the files and directories in a directory and all subdirectories. +-- +-- The directory structure is traversed depth-first. +-- +-- The result is generated lazily so is not well defined if the source +-- directory structure changes before the list is fully consumed. +-- +-- Symlinks within directory structure may cause result to be infinitely long. +getDirectoryContentsRecursive + :: OsPath + -> IO [(OsPath, FileType)] +getDirectoryContentsRecursive root = + listContentsRecFold' + Nothing + (\_ _ (Relative path) _ ft _ cons prependSubdir rest -> cons (path, ft) $ prependSubdir rest) + (\_ _ (Relative path) _ ft -> pure (Just (path, ft))) + (Just root) + +{-# INLINE listContentsRecFold #-} +-- | The most general form of gathering directory contents. +-- +-- Treats symlinks the same as regular files and directories. Folding functions can +-- decide how to handle symlinks. +-- +-- Both directory and file actions can throw exceptions and this function +-- will try to close finished directory streams promptly (they’ll be closed +-- by GC in the worst case). +listContentsRecFold + :: forall f a b. (Foldable f, Coercible b OsPath) + => Maybe Int + -- ^ Depth limit if specified, negative values treated the same as positive ones. + -> (forall c. OsPath -> b -> Relative OsPath -> Basename OsPath -> SymlinkType -> (a -> IO c -> IO c) -> (IO c -> IO c) -> IO c -> IO c) + -- ^ Decide how to fold directory and its children given its path. + -- + -- Can do IO actions to plan what to do and typically should derive its + -- result from last @IO c@ argument. + -- + -- Returns @IO c@ where @c@ is hidden from the user so the only way + -- to make it is to construct from the passed @IO c@ action. + -- + -- Arguments: + -- + -- * @OsPath@ - absolute path to the visited directory + -- * @b@ - root of the visited directory as passed originally in @f b@ to the bigger fold function + -- * @Relative OsPath@ - path to the visited directory relative to the previous @b@ argument + -- * @Basename OsPath@ - name of the visited directory without slashes + -- * @SymlinkType@ - symlink status of the visited directory + -- * @(a -> IO c -> IO c)@ - can be used to record some output (@a@) about the directory itself + -- * @(IO c -> IO c)@ - traverse inside this directory, can be ignored to skip its children + -- * @IO c@ - continue scanning not yet visited parts, must be used to construct return value (otherwise it won’t typecheck!) + -- + -- The passed @(IO c -> IO c)@ argument function should (but is not required to) + -- be applied in the returned function and it will prepend results for subdirectories + -- of the directory being analyzed. If not applied these subdirectories will be skipped, + -- this way ignoring particular directory and all its children can be achieved. + -> (OsPath -> b -> Relative OsPath -> Basename OsPath -> FileType -> IO (Maybe a)) + -- ^ What to do with file + -> f b + -- ^ Roots to search in, either absolute or relative + -> IO [a] +listContentsRecFold = \depthLimit foldDir filePred input -> + listContentsRecFold' depthLimit (\a b c d _f g h i j -> foldDir a b c d g h i j) filePred input + +{-# INLINE listContentsRecFold' #-} +-- Actual worker with slightly worse type signature that we don’t want to expose to the users. +-- But it’s better candidate for implementing getDirectoryContentsRecursive here that +-- listContentsRecFold. +listContentsRecFold' + :: forall f a b. (Foldable f, Coercible b OsPath) + => Maybe Int + -> (forall c. OsPath -> b -> Relative OsPath -> Basename OsPath -> FileType -> SymlinkType -> (a -> IO c -> IO c) -> (IO c -> IO c) -> IO c -> IO c) + -> (OsPath -> b -> Relative OsPath -> Basename OsPath -> FileType -> IO (Maybe a)) + -> f b + -> IO [a] +listContentsRecFold' depthLimit foldDir filePred input = + goCache =<< Raw.allocateDirReadCache + where + goCache cache = + foldr (goNewDir initLimit) (Raw.releaseDirReadCache cache *> pure []) input + where + !initLimit = case depthLimit of + Nothing -> -1 -- Loop until overflow, basically infinitely + Just x -> abs x + + goNewDir :: Int -> b -> IO [a] -> IO [a] + goNewDir !d root rest = + mask $ \restore -> do + stream <- Streaming.openDirStream $ coerce root + (restore + (goDirStream root d (Streaming.closeDirStream stream *> rest) stream)) + + goDirStream :: b -> Int -> IO [a] -> DirStream -> IO [a] + goDirStream _ 0 rest _ = rest + goDirStream root depth rest stream = go + where + go :: IO [a] + go = (`onException` Streaming.closeDirStream stream) $ do + x <- Streaming.readDirStreamWithCache cache stream + case x of + Nothing -> rest + Just (yAbs, yBase, ft) -> do + let yRel :: Relative OsPath + yRel = coerce yBase + case ft of + Other _ -> addLazy (filePred yAbs root yRel yBase ft) go + File _ -> addLazy (filePred yAbs root yRel yBase ft) go + Directory ft' -> foldDir yAbs root yRel yBase ft ft' cons (goNewDirAcc yRel (depth - 1) yAbs) go + + goNewDirAcc :: Relative OsPath -> Int -> OsPath -> IO [a] -> IO [a] + goNewDirAcc rootAcc !d dir rest1 = + mask $ \restore -> do + stream1 <- Streaming.openDirStream dir + (restore + (goDirStreamAcc rootAcc d (Streaming.closeDirStream stream1 *> rest1) stream1)) + + goDirStreamAcc :: Relative OsPath -> Int -> IO [a] -> DirStream -> IO [a] + goDirStreamAcc _ 0 rest1 _ = rest1 + goDirStreamAcc rootAcc depth1 rest1 stream1 = go1 + where + go1 :: IO [a] + go1 = (`onException` Streaming.closeDirStream stream1) $ do + x <- Streaming.readDirStreamWithCache cache stream1 + case x of + Nothing -> rest1 + Just (yAbs, yBase, ft) -> do + let yRel :: Relative OsPath + yRel = coerce () rootAcc yBase + case ft of + Other _ -> addLazy (filePred yAbs root yRel yBase ft) go1 + File _ -> addLazy (filePred yAbs root yRel yBase ft) go1 + Directory ft' -> foldDir yAbs root yRel yBase ft ft' cons (goNewDirAcc yRel (depth1 - 1) yAbs) go1 + + addLazy :: IO (Maybe a) -> IO [a] -> IO [a] + addLazy x y = do + x' <- x + case x' of + Nothing -> y + Just x'' -> cons x'' y + + cons :: a -> IO [a] -> IO [a] + cons x y = + (x :) <$> unsafeInterleaveIO y diff --git a/src/System/Directory/OsPath/FileType.hs b/src/System/Directory/OsPath/FileType.hs --- a/src/System/Directory/OsPath/FileType.hs +++ b/src/System/Directory/OsPath/FileType.hs @@ -1,6 +1,6 @@ -- | -- Module: System.Directory.OsPath.FileType --- Copyright: (c) Sergey Vinokurov 2023 +-- Copyright: (c) Sergey Vinokurov 2024 -- License: Apache-2.0 (see LICENSE) -- Maintainer: serg.foo@gmail.com @@ -8,53 +8,66 @@ {-# LANGUAGE ScopedTypeVariables #-} module System.Directory.OsPath.FileType - ( FileType(..) - , getFileType + ( getFileType + + , regularFile + , regularDirectory + , regularOther + , symlinkFile + , symlinkDirectory + , symlinkOther ) where import System.OsPath.Types (OsPath) +import System.Directory.OsPath.Types #ifdef mingw32_HOST_OS - import System.Directory.OsPath (doesFileExist, doesDirectoryExist) +#endif +#ifndef mingw32_HOST_OS +import Control.Exception (try, IOException) +import System.OsString.Internal.Types (getOsString) +import qualified System.Posix.Files.PosixString as PosixF +#endif getFileType :: OsPath -> IO FileType +#ifdef mingw32_HOST_OS getFileType fp = do isFile <- doesFileExist fp if isFile - then pure File + then pure regularFile else do isDir <- doesDirectoryExist fp - pure $ if isDir then Directory else Other - -#else - -import Control.Exception (try, IOException) -import System.OsString.Internal.Types (getOsString) -import qualified System.Posix.Files.PosixString as PosixF - -getFileType :: OsPath -> IO FileType + pure $ if isDir then regularDirectory else regularOther +#endif +#ifndef mingw32_HOST_OS getFileType fp = do s <- PosixF.getSymbolicLinkStatus $ getOsString fp case () of - _ | PosixF.isRegularFile s -> pure File - | PosixF.isDirectory s -> pure Directory + _ | PosixF.isRegularFile s -> pure regularFile + | PosixF.isDirectory s -> pure regularDirectory | PosixF.isSymbolicLink s -> do es' <- try $ PosixF.getFileStatus $ getOsString fp case es' of - Left (_ :: IOException) -> pure Other + Left (_ :: IOException) -> pure symlinkOther Right s' - | PosixF.isRegularFile s' -> pure FileSym - | PosixF.isDirectory s' -> pure DirectorySym - | otherwise -> pure Other - | otherwise -> pure Other - + | PosixF.isRegularFile s' -> pure symlinkFile + | PosixF.isDirectory s' -> pure symlinkDirectory + | otherwise -> pure symlinkOther + | otherwise -> pure regularOther #endif -data FileType - = File - | FileSym -- ^ Symlink to a file. - | Directory - | DirectorySym -- ^ Symlink to a directory. - | Other - deriving (Show, Read, Eq, Ord) +-- Avoid allocations with this one weird trick. +{-# NOINLINE regularFile #-} +{-# NOINLINE regularDirectory #-} +{-# NOINLINE symlinkFile #-} +{-# NOINLINE symlinkDirectory #-} +-- | Auxiliary constants to refer to different file types without +-- allocations. +regularFile, regularDirectory, regularOther, symlinkFile, symlinkDirectory, symlinkOther :: FileType +regularFile = File Regular +regularDirectory = Directory Regular +regularOther = Other Regular +symlinkFile = File Symlink +symlinkDirectory = Directory Symlink +symlinkOther = Other Symlink diff --git a/src/System/Directory/OsPath/Streaming.hs b/src/System/Directory/OsPath/Streaming.hs --- a/src/System/Directory/OsPath/Streaming.hs +++ b/src/System/Directory/OsPath/Streaming.hs @@ -1,78 +1,42 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | Streaming functions for interacting with the filesystem. +-- | +-- Module: System.Directory.OsPath.SafeStreaming +-- Copyright: (c) Sergey Vinokurov 2024 +-- License: Apache-2.0 (see LICENSE) +-- Maintainer: serg.foo@gmail.com +-- +-- You’ll most likely be interested in either +-- +-- * 'getDirectoryContentsRecursive' to search directory hierarchy recursively +-- * 'DirStream', 'openDirStream', 'readDirStream', and 'closeDirStream' to traverse single directory efficiently module System.Directory.OsPath.Streaming ( DirStream , openDirStream , readDirStream , closeDirStream - ) where -import System.OsPath (osp) - -#ifdef mingw32_HOST_OS - -import Control.Concurrent.Counter (Counter) -import qualified Control.Concurrent.Counter as Counter -import Control.Monad (unless) -import System.OsPath.Types (OsPath) -import System.OsString.Internal.Types (OsString(OsString), getOsString) -import System.OsString.Windows (pstr) -import qualified System.Win32.Types as Win32 -import qualified System.Win32.WindowsString.File as Win32 - -data DirStream = DirStream !Win32.HANDLE !Win32.FindData !Counter - -openDirStream :: OsPath -> IO DirStream -openDirStream fp = do - (h, fdat) <- Win32.findFirstFile $ getOsString fp <> [pstr|\*|] - hasMore <- Counter.new 1 -- always at least two records, "." and ".." - pure $! DirStream h fdat hasMore - -closeDirStream :: DirStream -> IO () -closeDirStream (DirStream h _ _) = Win32.findClose h - -readDirStream :: DirStream -> IO (Maybe OsPath) -readDirStream (DirStream h fdat hasMore) = go - where - go = do - hasMore' <- Counter.get hasMore - if hasMore' /= 0 - then do - filename <- Win32.getFindDataFileName fdat - hasMore'' <- Win32.findNextFile h fdat - unless hasMore'' $ - Counter.set hasMore 0 - if filename == getOsString [osp|.|] || filename == getOsString [osp|..|] - then go - else pure $ Just $ OsString filename - else pure Nothing + -- * File types + , SymlinkType(..) + , FileType(..) + , Basename(..) + , getFileType -#else + -- * Get directory contents + , getDirectoryContentsRecursive -import System.OsPath.Types (OsPath) -import System.OsString.Internal.Types (OsString(OsString), getOsString) -import System.Posix.Directory.PosixPath (DirStream, closeDirStream) -import qualified System.Posix.Directory.PosixPath as Posix + , listContentsRecFold -openDirStream :: OsPath -> IO DirStream -openDirStream = Posix.openDirStream . getOsString + -- * Utilities + , regularFile + , regularDirectory + , regularOther + , symlinkFile + , symlinkDirectory + , symlinkOther + ) where -{-# INLINE readDirStream #-} -readDirStream :: DirStream -> IO (Maybe OsPath) -readDirStream ds = go - where - go = do - fp <- Posix.readDirStream ds - case () of - _ | fp == mempty - -> pure Nothing - | fp == getOsString [osp|.|] || fp == getOsString [osp|..|] - -> go - | otherwise - -> pure $ Just $ OsString fp +import System.Directory.OsPath.Contents +import System.Directory.OsPath.FileType +import System.Directory.OsPath.Streaming.Internal as Streaming +import System.Directory.OsPath.Types -#endif diff --git a/src/System/Directory/OsPath/Streaming/Internal.hs b/src/System/Directory/OsPath/Streaming/Internal.hs new file mode 100644 --- /dev/null +++ b/src/System/Directory/OsPath/Streaming/Internal.hs @@ -0,0 +1,71 @@ +-- | +-- Module: System.Directory.OsPath.Streaming.Internal +-- Copyright: (c) Sergey Vinokurov 2024 +-- License: Apache-2.0 (see LICENSE) +-- Maintainer: serg.foo@gmail.com + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE UnboxedTuples #-} + +module System.Directory.OsPath.Streaming.Internal + ( DirStream(..) + , openDirStream + , readDirStream + , closeDirStream + + , readDirStreamWithCache + ) where + +import Control.Concurrent.Counter (Counter) +import qualified Control.Concurrent.Counter as Counter +import Control.Monad (when) +import System.Mem.Weak (Weak, mkWeak, finalize) +import System.OsPath (OsPath) + +import qualified System.Directory.OsPath.Streaming.Internal.Raw as Raw +import System.Directory.OsPath.Types + +-- | Abstract handle to directory contents. +-- +-- May be closed multiple times and will be automatically closed by GC +-- when it goes out of scope. +data DirStream = DirStream + { dsHandle :: !Raw.RawDirStream + , dsIsClosed :: {-# UNPACK #-} !Counter + , dsFin :: {-# UNPACK #-} !(Weak DirStream) + } + +openDirStream :: OsPath -> IO DirStream +openDirStream root = mdo + dsHandle <- Raw.openRawDirStream root + dsIsClosed <- Counter.new 0 + let result = DirStream{dsHandle, dsIsClosed, dsFin} + dsFin <- mkWeak result result (Just (closeDirStreamInternal result)) + pure result + +-- | Deallocate directory handle. It’s safe to close 'DirStream' multiple times, +-- unlike the underlying OS-specific directory stream handle. +closeDirStream :: DirStream -> IO () +closeDirStream stream = + -- Finalize ourselves to do it only once instead of running finalizer + -- in GC afterwards once more. + finalize (dsFin stream) + +closeDirStreamInternal :: DirStream -> IO () +closeDirStreamInternal DirStream{dsHandle, dsIsClosed} = do + !oldVal <- Counter.cas dsIsClosed 0 1 + when (oldVal == 0) $ + Raw.closeRawDirStream dsHandle + +readDirStream :: DirStream -> IO (Maybe (OsPath, FileType)) +readDirStream = Raw.readRawDirStream . dsHandle + +readDirStreamWithCache + :: Raw.DirReadCache + -> DirStream + -> IO (Maybe (OsPath, Basename OsPath, FileType)) +readDirStreamWithCache cache = + Raw.readRawDirStreamWithCache cache . dsHandle diff --git a/src/System/Directory/OsPath/Streaming/Internal/Raw.hs b/src/System/Directory/OsPath/Streaming/Internal/Raw.hs new file mode 100644 --- /dev/null +++ b/src/System/Directory/OsPath/Streaming/Internal/Raw.hs @@ -0,0 +1,300 @@ +-- | +-- Module: System.Directory.OsPath.Streaming.Internal.Raw +-- Copyright: (c) Sergey Vinokurov 2024 +-- License: Apache-2.0 (see LICENSE) +-- Maintainer: serg.foo@gmail.com +-- +-- Streaming functions for interacting with the filesystem. +-- +-- These do the basic job of reading directory entries but care must +-- be taken to not close these streams more than once. + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UnboxedTuples #-} + +#ifndef mingw32_HOST_OS +# if MIN_VERSION_unix(2, 8, 6) && __GLASGOW_HASKELL__ >= 902 +# define HAVE_UNIX_CACHE 1 +# endif +#endif + +module System.Directory.OsPath.Streaming.Internal.Raw + ( RawDirStream(..) + , openRawDirStream + , readRawDirStream + , closeRawDirStream + + , DirReadCache(..) + , allocateDirReadCache + , releaseDirReadCache + , readRawDirStreamWithCache + ) where + +import System.OsPath (osp, ()) + +import System.Directory.OsPath.FileType +import System.Directory.OsPath.Types + +#ifdef mingw32_HOST_OS +import Control.Concurrent.Counter (Counter) +import qualified Control.Concurrent.Counter as Counter +import Control.Monad (unless) +import System.OsPath.Types (OsPath) +import System.OsString.Internal.Types (OsString(OsString), getOsString) +import System.OsString.Windows (pstr) +import qualified System.Win32.Types as Win32 +import qualified System.Win32.WindowsString.File as Win32 +#endif + +-- Don’t use #else to make treesitter do better job - it parses #else part as comments. +#ifndef mingw32_HOST_OS +import System.OsPath.Types (OsPath) +import System.OsString.Internal.Types (OsString(OsString), getOsString) +import qualified System.Posix.Directory.PosixPath as Posix + +# ifdef HAVE_UNIX_CACHE +import Data.Coerce (coerce) +import Foreign.C (CString, CChar) +import Foreign.Ptr (Ptr, nullPtr) +import Foreign.Storable (sizeOf, alignment, peekElemOff) +import qualified System.Posix.Directory.Internals as DirInternals +import System.Posix.PosixPath.FilePath (peekFilePath) + +import GHC.Exts (MutableByteArray#, newAlignedPinnedByteArray#, touch#, mutableByteArrayContents#, RealWorld) +import GHC.IO (IO(..)) +import GHC.Int (Int(..)) +import GHC.Ptr (Ptr(..)) +# endif +#endif + +-- | Abstract handle to directory contents. +-- +-- Not thread safe and shouldn't be closed more than once. + +#ifdef mingw32_HOST_OS +data RawDirStream = RawDirStream !Win32.HANDLE !Win32.FindData !Counter !OsPath +#endif +#ifndef mingw32_HOST_OS +data RawDirStream = RawDirStream !Posix.DirStream !OsPath +#endif + +openRawDirStream :: OsPath -> IO RawDirStream +#ifdef mingw32_HOST_OS +openRawDirStream fp = do + (h, fdat) <- Win32.findFirstFile $ getOsString fp <> [pstr|\*|] + hasMore <- Counter.new 1 -- always at least two records, "." and ".." + pure $! RawDirStream h fdat hasMore fp +#endif + +#ifndef mingw32_HOST_OS +openRawDirStream root = do + stream <- Posix.openDirStream (getOsString root) + pure $ RawDirStream stream root +#endif + +-- | Deallocate directory handle. It’s not safe to call multiple times +-- on the same handle. +closeRawDirStream :: RawDirStream -> IO () + +#ifdef mingw32_HOST_OS +closeRawDirStream (RawDirStream h _ _ _) = Win32.findClose h +#endif +#ifndef mingw32_HOST_OS +closeRawDirStream (RawDirStream stream _) = Posix.closeDirStream stream +#endif + +readRawDirStream :: RawDirStream -> IO (Maybe (OsPath, FileType)) +readRawDirStream stream = do + cache <- allocateDirReadCache + res <- readRawDirStreamWithCache cache stream + -- Safe to don’t care about exceptions because we know that cache is + -- just a byte vector so just touch# it for now. + releaseDirReadCache cache + pure $ (\(_, Basename x, typ) -> (x, typ)) <$> res + +#ifdef mingw32_HOST_OS +-- No state on Windows +newtype DirReadCache = DirReadCache () +#endif + +#ifndef mingw32_HOST_OS + +# ifndef HAVE_UNIX_CACHE +-- No state in early unix package +newtype DirReadCache = DirReadCache () +# endif + +# ifdef HAVE_UNIX_CACHE +data DirReadCache = DirReadCache (MutableByteArray# RealWorld) +# endif + +#endif + + +allocateDirReadCache :: IO DirReadCache +#ifdef mingw32_HOST_OS +allocateDirReadCache = pure $ DirReadCache () +#endif + +#ifndef mingw32_HOST_OS +# ifndef HAVE_UNIX_CACHE +allocateDirReadCache = pure $ DirReadCache () +# endif +# ifdef HAVE_UNIX_CACHE +allocateDirReadCache = IO $ \s0 -> + case newAlignedPinnedByteArray# size align s0 of + (# s1, mbarr# #) -> + (# s1, DirReadCache mbarr# #) + where + !(I# size) = sizeOf (undefined :: Ptr DirInternals.DirEnt) + !(I# align) = alignment (undefined :: Ptr DirInternals.DirEnt) +# endif +#endif + + +releaseDirReadCache :: DirReadCache -> IO () +#ifdef mingw32_HOST_OS +releaseDirReadCache _ = pure () +#endif +#ifndef mingw32_HOST_OS + +# ifndef HAVE_UNIX_CACHE +releaseDirReadCache _ = pure () +# endif +# ifdef HAVE_UNIX_CACHE +releaseDirReadCache (DirReadCache barr#) = + IO $ \s0 -> case touch# barr# s0 of s1 -> (# s1, () #) +# endif +#endif + + +readRawDirStreamWithCache + :: DirReadCache + -> RawDirStream + -> IO (Maybe (OsPath, Basename OsPath, FileType)) +#ifdef mingw32_HOST_OS +readRawDirStreamWithCache _ stream@(RawDirStream _ _ _ root) = do + traverse (\x -> let full = root x in (full, Basename x,) <$> getFileType full) =<< _readRawDirStreamSimple stream +#endif +#ifndef mingw32_HOST_OS + +# ifndef HAVE_UNIX_CACHE +readRawDirStreamWithCache _ stream@(RawDirStream _ root) = do + traverse (\x -> let full = root x in (full, Basename x,) <$> getFileType full) =<< _readRawDirStreamSimple stream +# endif +# ifdef HAVE_UNIX_CACHE +readRawDirStreamWithCache (DirReadCache barr#) (RawDirStream stream root) = go + where + cache :: Ptr DirInternals.DirEnt + cache = Ptr (mutableByteArrayContents# barr#) + + shouldSkipDirEntry :: CString -> IO Bool + shouldSkipDirEntry ptr + | ptr == nullPtr = pure True + shouldSkipDirEntry ptr = do + (x1 :: CChar) <- peekElemOff ptr 0 + case x1 of + 0 -> pure False + 46 -> do -- ASCII for ‘.’ + (x2 :: CChar) <- peekElemOff ptr 1 + case x2 of + 0 -> pure True + 46 -> do -- ASCII for ‘.’ + (x3 :: CChar) <- peekElemOff ptr 2 + pure $! x3 == 0 + _ -> pure False + _ -> pure False + + go :: IO (Maybe (OsPath, Basename OsPath, FileType)) + go = do + x <- DirInternals.readDirStreamWithPtr + cache + (\dirEnt -> do + (namePtr :: CString) <- DirInternals.dirEntName dirEnt + + shouldSkip <- shouldSkipDirEntry namePtr + + if shouldSkip + then + pure Nothing + else do + !path <- peekFilePath namePtr + + let fullPath = root coerce path + + !typ <- DirInternals.dirEntType dirEnt + + typ' <- case typ of + DirInternals.UnknownType -> getFileType fullPath + DirInternals.NamedPipeType -> pure regularOther + DirInternals.CharacterDeviceType -> pure regularOther + DirInternals.DirectoryType -> pure regularDirectory + DirInternals.BlockDeviceType -> pure regularOther + DirInternals.RegularFileType -> pure regularFile + DirInternals.SymbolicLinkType -> getFileType fullPath + DirInternals.SocketType -> pure regularOther + DirInternals.WhiteoutType -> pure regularOther + -- Unaccounted type, probably should not happeen since the + -- list above is exhaustive. + _ -> getFileType fullPath + + pure (Just (fullPath, Basename $ coerce path, typ'))) + stream + + case x of + Nothing -> pure Nothing + Just Nothing -> go + Just res@(Just _) -> pure res +# endif +#endif + +_readRawDirStreamSimple :: RawDirStream -> IO (Maybe OsPath) + +#ifdef mingw32_HOST_OS +_readRawDirStreamSimple (RawDirStream h fdat hasMore _) = go + where + go = do + hasMore' <- Counter.get hasMore + if hasMore' /= 0 + then do + filename <- Win32.getFindDataFileName fdat + hasMore'' <- Win32.findNextFile h fdat + unless hasMore'' $ + Counter.set hasMore 0 + if filename == getOsString [osp|.|] || filename == getOsString [osp|..|] + then go + else pure $ Just $ OsString filename + else pure Nothing +#endif +#ifndef mingw32_HOST_OS +_readRawDirStreamSimple (RawDirStream stream _) = go + where +# ifndef HAVE_UNIX_CACHE + go = do + fp <- Posix.readDirStream stream + case () of + _ | fp == mempty + -> pure Nothing + | fp == getOsString [osp|.|] || fp == getOsString [osp|..|] + -> go + | otherwise + -> pure $ Just $ OsString fp +# endif +# ifdef HAVE_UNIX_CACHE + go = do + fp <- Posix.readDirStreamMaybe stream + case fp of + Nothing -> pure Nothing + Just fp' + | fp' == getOsString [osp|.|] || fp' == getOsString [osp|..|] + -> go + | otherwise + -> pure $ Just $ OsString fp' +# endif +#endif + diff --git a/src/System/Directory/OsPath/Types.hs b/src/System/Directory/OsPath/Types.hs new file mode 100644 --- /dev/null +++ b/src/System/Directory/OsPath/Types.hs @@ -0,0 +1,42 @@ +-- | +-- Module: System.Directory.OsPath.Types +-- Copyright: (c) Sergey Vinokurov 2024 +-- License: Apache-2.0 (see LICENSE) +-- Maintainer: serg.foo@gmail.com + +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module System.Directory.OsPath.Types + ( SymlinkType(..) + , FileType(..) + , Basename(..) + , Relative(..) + ) where + +import Control.DeepSeq (NFData) +import GHC.Generics (Generic, Generic1) + +data SymlinkType = Regular | Symlink + deriving (Show, Read, Eq, Ord, Generic) + +instance NFData SymlinkType + +data FileType + = File {-# UNPACK #-} !SymlinkType + | Directory {-# UNPACK #-} !SymlinkType + | Other {-# UNPACK #-} !SymlinkType + deriving (Show, Read, Eq, Ord, Generic) + +instance NFData FileType + +-- | Basename part of filename, without directory separators. +newtype Basename a = Basename { unBasename :: a } + deriving (Eq, Ord, Show, Generic, Generic1, NFData, Functor, Foldable, Traversable) + +-- | Filename relative to some other path. +newtype Relative a = Relative { unRelative :: a } + deriving (Eq, Ord, Show, Generic, Generic1, NFData, Functor, Foldable, Traversable) diff --git a/test/TestMain.hs b/test/TestMain.hs --- a/test/TestMain.hs +++ b/test/TestMain.hs @@ -17,7 +17,6 @@ import qualified Data.List as L import System.OsPath -import System.Directory.OsPath.FileType import System.Directory.OsPath.Streaming import Test.Tasty @@ -44,13 +43,19 @@ Just y <- readDirStream ds Just z <- readDirStream ds return $ L.sort [w, x, y, z] - res @?= [[osp|bar.txt|], [osp|baz.txt|], [osp|bin|], [osp|foo.txt|]] + res @?= [([osp|bar.txt|], File Regular), ([osp|baz.txt|], File Regular), ([osp|bin|], Directory Regular), ([osp|foo.txt|], File Regular)] + , testGroup "getFileType general" [ testCase "file" $ do - getFileType [osp|directory-ospath-streaming.cabal|] >>= (@?= File) + getFileType [osp|directory-ospath-streaming.cabal|] >>= (@?= File Regular) , testCase "directory" $ do - getFileType [osp|test|] >>= (@?= Directory) + getFileType [osp|test|] >>= (@?= Directory Regular) ] + + , testCase "getDirectoryContentsRecursive" $ do + res <- L.sort <$> getDirectoryContentsRecursive [osp|test/filesystem|] + res @?= [([osp|bar.txt|], File Regular), ([osp|baz.txt|], File Regular), ([osp|bin|], Directory Regular), ([osp|bin|] [osp|bin.txt|], File Regular), ([osp|foo.txt|], File Regular)] + #ifndef mingw32_HOST_OS , withResource (do @@ -66,7 +71,7 @@ (getOsString (currDir [osp|directory-ospath-streaming.cabal|])) (getOsString dest) ft <- getFileType dest - ft @?= FileSym + ft @?= File Symlink , testCase "directory symlink" $ do tmp <- mkTmpDir currDir <- getCurrentDirectory @@ -75,17 +80,17 @@ (getOsString (currDir [osp|src|])) (getOsString dest) ft <- getFileType dest - ft @?= DirectorySym + ft @?= Directory Symlink , testCase "other" $ do tmp <- mkTmpDir let dest = tmp [osp|tmp3|] - res <- tryIO $ Posix.createNamedPipe (getOsString dest) 0 + res <- tryIO $ Posix.createNamedPipe (getOsString dest) 0 case res of -- Creating named pipe might fail on some filesystems Left _ -> pure () Right _ -> do ft <- getFileType dest - ft @?= Other + ft @?= Other Regular , testCase "recursive symlink is other" $ do tmp <- mkTmpDir let dest = tmp [osp|tmp4|] @@ -93,7 +98,7 @@ (getOsString dest) (getOsString dest) ft <- getFileType dest - ft @?= Other + ft @?= Other Symlink , testCase "dangling symlink is other" $ do tmp <- mkTmpDir let dest = tmp [osp|tmp5|] @@ -101,7 +106,7 @@ (getOsString (tmp [osp|does-not-exist|])) (getOsString dest) ft <- getFileType dest - ft @?= Other + ft @?= Other Symlink ] #endif ]