diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,8 @@ +# 0.3 + +- Remove `DirReadCache` since it was not doing anything most of the time. It was only used for the `readdir_r` libc function which is deprecated and is not typically used by default in the `unix` package (cf https://github.com/haskell/unix/pull/349) +- Add new function `readDirStreamFull` that is like `readDirStream` but also returns full path to the directory entry to let clients reuse the full path from the stream root that would be created anyway + # 0.2.2 - Add `getDirectoryContentsWithFilterRecursive` for recursively listing directory contents with commonly needed filtering 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.2 + 0.3 synopsis: Stream directory entries in constant memory in vanilla IO description: @@ -39,6 +39,7 @@ , GHC == 9.6 , GHC == 9.8 , GHC == 9.10 + , GHC == 9.12 build-type: Simple 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 @@ -23,7 +23,6 @@ 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. @@ -103,7 +102,7 @@ -- -- Arguments: -- - -- * @OsPath@ - absolute path to the visited directory + -- * @OsPath@ - full path to the visited directory relative to root we’re searching in. If the root was absolute then this path would be too, if it was relative then this path would be relative to the same target. -- * @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 @@ -136,66 +135,63 @@ -> f b -> IO [a] listContentsRecFold' depthLimit foldDir filePred input = - goCache =<< Raw.allocateDirReadCache + foldr (goNewDir initLimit) (pure []) input where - goCache cache = - foldr (goNewDir initLimit) (Raw.releaseDirReadCache cache *> pure []) input + !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 = do + stream <- Streaming.openDirStream $ coerce root + goToplevelDirStream root d (Streaming.closeDirStream stream *> rest) stream + + goToplevelDirStream :: b -> Int -> IO [a] -> DirStream -> IO [a] + goToplevelDirStream _ 0 rest _ = rest + goToplevelDirStream root depth rest stream = go where - !initLimit = case depthLimit of - Nothing -> -1 -- Loop until overflow, basically infinitely - Just x -> abs x + go :: IO [a] + go = (`onException` Streaming.closeDirStream stream) $ do + x <- Streaming.readDirStreamFull 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 (goChildDirAcc yRel (depth - 1) yAbs) go - goNewDir :: Int -> b -> IO [a] -> IO [a] - goNewDir !d root rest = do - stream <- Streaming.openDirStream $ coerce root - goDirStream root d (Streaming.closeDirStream stream *> rest) stream + goChildDirAcc :: Relative OsPath -> Int -> OsPath -> IO [a] -> IO [a] + goChildDirAcc rootAcc !d dir rest1 = do + stream1 <- Streaming.openDirStream dir + goChildDirStreamAcc (coerce addTrailingPathSeparator rootAcc) d (Streaming.closeDirStream stream1 *> rest1) stream1 - goDirStream :: b -> Int -> IO [a] -> DirStream -> IO [a] - goDirStream _ 0 rest _ = rest - goDirStream root depth rest stream = go + goChildDirStreamAcc :: Relative OsPath -> Int -> IO [a] -> DirStream -> IO [a] + goChildDirStreamAcc _ 0 rest1 _ = rest1 + goChildDirStreamAcc rootAcc depth1 rest1 stream1 = go1 where - go :: IO [a] - go = (`onException` Streaming.closeDirStream stream) $ do - x <- Streaming.readDirStreamWithCache cache stream + go1 :: IO [a] + go1 = (`onException` Streaming.closeDirStream stream1) $ do + x <- Streaming.readDirStreamFull stream1 case x of - Nothing -> rest + Nothing -> rest1 Just (yAbs, yBase, ft) -> do let yRel :: Relative OsPath - yRel = coerce yBase + yRel = coerce ((<>) :: OsPath -> OsPath -> OsPath) rootAcc 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 = 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 - 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 + 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 (goChildDirAcc 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 + 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 + cons :: a -> IO [a] -> IO [a] + cons x y = + (x :) <$> unsafeInterleaveIO y 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 @@ -13,6 +13,7 @@ ( DirStream , openDirStream , readDirStream + , readDirStreamFull , closeDirStream -- * File types 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 @@ -14,9 +14,8 @@ ( DirStream(..) , openDirStream , readDirStream + , readDirStreamFull , closeDirStream - - , readDirStreamWithCache ) where import Control.Concurrent.Counter (Counter) @@ -44,7 +43,7 @@ dsHandle <- Raw.openRawDirStream root dsIsClosed <- Counter.new 0 let stream = DirStream{dsHandle, dsIsClosed, dsFin} - dsFin <- mkWeak stream stream (Just (closeDirStreamInternal stream)) + dsFin <- mkWeak stream stream (Just (closeDirStreamInternal stream)) pure stream -- | Deallocate directory handle. It’s safe to close 'DirStream' multiple times, @@ -62,12 +61,26 @@ when (oldVal == 0) $ Raw.closeRawDirStream dsHandle +-- | Returns basename path of the directory entry. readDirStream :: DirStream -> IO (Maybe (OsPath, FileType)) -readDirStream = Raw.readRawDirStream . dsHandle +readDirStream = + fmap (fmap (\(_full, Basename x, typ) -> (x, typ))) . readDirStreamFull -readDirStreamWithCache - :: Raw.DirReadCache - -> DirStream - -> IO (Maybe (OsPath, Basename OsPath, FileType)) -readDirStreamWithCache cache = - Raw.readRawDirStreamWithCache cache . dsHandle +-- | Returns both basename path and full path of a directory entry relative to the +-- passed 'DirStream' root. +-- +-- For example: +-- +-- > readDirStreamFull =<< openDirStream [osp|.|] +-- > Just ("./bar",Basename {unBasename = "foo"},File Regular) +-- +-- > readDirStreamFull =<< openDirStream [osp|foo/|] +-- > Just ("foo/bar",Basename {unBasename = "foo"},File Regular) +-- +-- > readDirStreamFull =<< openDirStream [osp|/foo/foo|] +-- > Just ("/foo/foo/bar",Basename {unBasename = "foo"},File Regular) +-- +-- This allows to avoid re-creating the full path on the client side +-- and thus reduce allocations. +readDirStreamFull :: DirStream -> IO (Maybe (OsPath, Basename OsPath, FileType)) +readDirStreamFull = Raw.readRawDirStream . dsHandle 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 @@ -17,25 +17,14 @@ {-# 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.OsPath (osp, addTrailingPathSeparator) import System.Directory.OsPath.FileType import System.Directory.OsPath.Types @@ -51,27 +40,11 @@ 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. +-- Don’t use #else to make treesitter do a 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#, mutableByteArrayContents#, RealWorld) -import GHC.IO (IO(..)) -import GHC.Int (Int(..)) -import GHC.Ptr (Ptr(..)) - -import System.Directory.OsPath.Utils (touch) -# endif #endif -- | Abstract handle to directory contents. @@ -90,13 +63,13 @@ 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 + pure $! RawDirStream h fdat hasMore $ addTrailingPathSeparator fp #endif #ifndef mingw32_HOST_OS openRawDirStream root = do stream <- Posix.openDirStream (getOsString root) - pure $ RawDirStream stream root + pure $ RawDirStream stream $ addTrailingPathSeparator root #endif -- | Deallocate directory handle. It’s not safe to call multiple times @@ -110,154 +83,23 @@ 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 = touch -# endif -#endif - - -readRawDirStreamWithCache - :: DirReadCache - -> RawDirStream +readRawDirStream + :: 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 +readRawDirStream stream@(RawDirStream _ _ _ root) = + readRawDirStreamSimple stream >>= + traverse (\x -> let full = root <> x in (full, Basename x,) <$> getFileType full) #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 +readRawDirStream stream@(RawDirStream _ root) = + readRawDirStreamSimple stream >>= + traverse (\x -> let full = root <> x in (full, Basename x,) <$> getFileType full) #endif -_readRawDirStreamSimple :: RawDirStream -> IO (Maybe OsPath) - +readRawDirStreamSimple :: RawDirStream -> IO (Maybe OsPath) #ifdef mingw32_HOST_OS -_readRawDirStreamSimple (RawDirStream h fdat hasMore _) = go +readRawDirStreamSimple (RawDirStream h fdat hasMore _) = go where go = do hasMore' <- Counter.get hasMore @@ -273,9 +115,8 @@ else pure Nothing #endif #ifndef mingw32_HOST_OS -_readRawDirStreamSimple (RawDirStream stream _) = go +readRawDirStreamSimple (RawDirStream stream _) = go where -# ifndef HAVE_UNIX_CACHE go = do fp <- Posix.readDirStream stream case () of @@ -285,17 +126,5 @@ -> 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/test/TestMain.hs b/test/TestMain.hs --- a/test/TestMain.hs +++ b/test/TestMain.hs @@ -14,10 +14,12 @@ module TestMain (main) where import Control.Exception +import Data.Functor.Identity (Identity(..)) import qualified Data.List as L import System.OsPath import System.Directory.OsPath.Streaming +import System.Directory.OsPath.Types import Test.Tasty import Test.Tasty.HUnit @@ -45,6 +47,18 @@ return $ L.sort [w, x, y, z] res @?= [([osp|bar.txt|], File Regular), ([osp|baz.txt|], File Regular), ([osp|bin|], Directory Regular), ([osp|foo.txt|], File Regular)] + , testCase "readDirStreamFull" $ do + let dir = [osp|test/filesystem|] + res <- bracket (openDirStream dir) closeDirStream $ \ds -> do + Just w <- readDirStreamFull ds + Just x <- readDirStreamFull ds + Just y <- readDirStreamFull ds + Just z <- readDirStreamFull ds + return $ L.sort [w, x, y, z] + res @?= map + (\(x, y) -> (dir x, Basename x, y)) + [([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 Regular) @@ -68,6 +82,22 @@ , testCase "getDirectoryContentsWithFilterRecursive 3" $ do res <- L.sort <$> getDirectoryContentsWithFilterRecursive (\_ _ -> True) (`elem` [Basename [osp|foo.txt|], Basename [osp|bin|], Basename [osp|bin.txt|]]) [osp|test/filesystem|] res @?= [([osp|bin|], Directory Regular), ([osp|bin|] [osp|bin.txt|], File Regular), ([osp|foo.txt|], File Regular)] + + , testCase "listContentsRecFold" $ do + let dir = [osp|test/filesystem|] + res <- fmap L.sort $ + listContentsRecFold + Nothing + (\a b c d e cons rec rest -> cons (a, b, c, d, Directory e) $ rec rest) + (\a b c d e -> pure $ Just (a, b, c, d, e)) + (Identity dir) + res @?= + [ (dir [osp|bar.txt|], dir, Relative [osp|bar.txt|], Basename [osp|bar.txt|], File Regular) + , (dir [osp|baz.txt|], dir, Relative [osp|baz.txt|], Basename [osp|baz.txt|], File Regular) + , (dir [osp|bin|], dir, Relative [osp|bin|], Basename [osp|bin|], Directory Regular) + , (dir [osp|bin|] [osp|bin.txt|], dir, Relative $ [osp|bin|] [osp|bin.txt|], Basename [osp|bin.txt|], File Regular) + , (dir [osp|foo.txt|], dir, Relative [osp|foo.txt|], Basename [osp|foo.txt|], File Regular) + ] ] #ifndef mingw32_HOST_OS