diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,10 +1,15 @@ +# 0.2.1 + +- Fix `listContentsRecFold` to not mask exceptions unnecessarily which could cause hangups. The `getDirectoryContentsRecursive` gets the fix as well +- Make `closeDirStream` hold on to the stream so it’s not GC’ed prematurely causing errors on reads. + # 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 +- 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 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.2 + 0.2.1 synopsis: Stream directory entries in constant memory in vanilla IO description: @@ -31,14 +31,14 @@ File, Streaming tested-with: - GHC == 8.6, - GHC == 8.8, - GHC == 8.10, - GHC == 9.2, - GHC == 9.4, - GHC == 9.6, - GHC == 9.8, - GHC == 9.10 + , GHC == 8.6 + , GHC == 8.8 + , GHC == 8.10 + , GHC == 9.2 + , GHC == 9.4 + , GHC == 9.6 + , GHC == 9.8 + , GHC == 9.10 build-type: Simple @@ -118,6 +118,7 @@ other-modules: System.Directory.OsPath.Contents System.Directory.OsPath.FileType + System.Directory.OsPath.Utils hs-source-dirs: src build-depends: diff --git a/src/System/Directory/OsPath/Contents.hs b/src/System/Directory/OsPath/Contents.hs --- a/src/System/Directory/OsPath/Contents.hs +++ b/src/System/Directory/OsPath/Contents.hs @@ -15,7 +15,7 @@ , listContentsRecFold ) where -import Control.Exception (mask, onException) +import Control.Exception (onException) import Data.Coerce (coerce, Coercible) import System.IO.Unsafe (unsafeInterleaveIO) import System.OsPath @@ -110,11 +110,9 @@ 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)) + goNewDir !d root rest = do + stream <- Streaming.openDirStream $ coerce root + goDirStream root d (Streaming.closeDirStream stream *> rest) stream goDirStream :: b -> Int -> IO [a] -> DirStream -> IO [a] goDirStream _ 0 rest _ = rest @@ -134,11 +132,9 @@ 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)) + goNewDirAcc rootAcc !d dir rest1 = do + stream1 <- Streaming.openDirStream dir + goDirStreamAcc rootAcc d (Streaming.closeDirStream stream1 *> rest1) stream1 goDirStreamAcc :: Relative OsPath -> Int -> IO [a] -> DirStream -> IO [a] goDirStreamAcc _ 0 rest1 _ = rest1 diff --git a/src/System/Directory/OsPath/Streaming/Internal.hs b/src/System/Directory/OsPath/Streaming/Internal.hs --- a/src/System/Directory/OsPath/Streaming/Internal.hs +++ b/src/System/Directory/OsPath/Streaming/Internal.hs @@ -27,6 +27,7 @@ import qualified System.Directory.OsPath.Streaming.Internal.Raw as Raw import System.Directory.OsPath.Types +import System.Directory.OsPath.Utils (touch) -- | Abstract handle to directory contents. -- @@ -42,17 +43,18 @@ 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 + let stream = DirStream{dsHandle, dsIsClosed, dsFin} + dsFin <- mkWeak stream stream (Just (closeDirStreamInternal stream)) + pure stream -- | Deallocate directory handle. It’s safe to close 'DirStream' multiple times, -- unlike the underlying OS-specific directory stream handle. closeDirStream :: DirStream -> IO () -closeDirStream stream = +closeDirStream stream = do -- Finalize ourselves to do it only once instead of running finalizer -- in GC afterwards once more. finalize (dsFin stream) + touch stream closeDirStreamInternal :: DirStream -> IO () closeDirStreamInternal DirStream{dsHandle, dsIsClosed} = do diff --git a/src/System/Directory/OsPath/Streaming/Internal/Raw.hs b/src/System/Directory/OsPath/Streaming/Internal/Raw.hs --- a/src/System/Directory/OsPath/Streaming/Internal/Raw.hs +++ b/src/System/Directory/OsPath/Streaming/Internal/Raw.hs @@ -65,10 +65,12 @@ import qualified System.Posix.Directory.Internals as DirInternals import System.Posix.PosixPath.FilePath (peekFilePath) -import GHC.Exts (MutableByteArray#, newAlignedPinnedByteArray#, touch#, mutableByteArrayContents#, RealWorld) +import GHC.Exts (MutableByteArray#, newAlignedPinnedByteArray#, mutableByteArrayContents#, RealWorld) import GHC.IO (IO(..)) import GHC.Int (Int(..)) import GHC.Ptr (Ptr(..)) + +import System.Directory.OsPath.Utils (touch) # endif #endif @@ -167,8 +169,7 @@ releaseDirReadCache _ = pure () # endif # ifdef HAVE_UNIX_CACHE -releaseDirReadCache (DirReadCache barr#) = - IO $ \s0 -> case touch# barr# s0 of s1 -> (# s1, () #) +releaseDirReadCache = touch # endif #endif diff --git a/src/System/Directory/OsPath/Utils.hs b/src/System/Directory/OsPath/Utils.hs new file mode 100644 --- /dev/null +++ b/src/System/Directory/OsPath/Utils.hs @@ -0,0 +1,18 @@ +-- | +-- Module: System.Directory.OsPath.Utils +-- Copyright: (c) Sergey Vinokurov 2024 +-- License: Apache-2.0 (see LICENSE) +-- Maintainer: serg.foo@gmail.com + +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module System.Directory.OsPath.Utils + ( touch + ) where + +import GHC.Exts (touch#) +import GHC.IO (IO(..)) + +touch :: x -> IO () +touch x = IO $ \s0 -> case touch# x s0 of s1 -> (# s1, () #)