diff --git a/doctests.hs b/doctests.hs --- a/doctests.hs +++ b/doctests.hs @@ -8,17 +8,20 @@ import Test.DocTest import Test.HUnit +main :: IO () main = do doctest [ "-isrc" , "-XOverloadedStrings" , "src/System/Posix/FilePath" ] - runTestTT unitTests + _ <- runTestTT unitTests + pure () unitTests :: Test unitTests = test [ TestCase $ do - r <- (==) <$> allDirectoryContents "." <*> allDirectoryContents' "." - assertBool "allDirectoryContents == allDirectoryContents'" r + a <- allDirectoryContents "." + b <- allDirectoryContents' "." + assertEqual "allDirectoryContents == allDirectoryContents'" a b ] diff --git a/posix-paths.cabal b/posix-paths.cabal --- a/posix-paths.cabal +++ b/posix-paths.cabal @@ -1,5 +1,5 @@ name: posix-paths -version: 0.2.1.6 +version: 0.3.0.1 license: BSD3 license-file: LICENSE maintainer: jwlato@gmail.com @@ -16,7 +16,7 @@ benchmarks/*.hs extra-tmp-files: build-type: Simple -Cabal-Version: >= 1.14 +Cabal-Version: 1.14 Library hs-source-dirs: src @@ -27,7 +27,11 @@ System.Posix.FilePath build-depends: base >= 4.2 && < 5, bytestring >= 0.9.2.0, - unix >= 2.5.1.0 + -- System.Posix.Directory.Internals (exposing the + -- DirStream constructor and CDir/CDirent types) was + -- introduced in unix-2.8.0.0 (August 2022). + unix >= 2.8.0.0, + unliftio >= 0.2 test-suite doctests default-language: Haskell2010 @@ -57,8 +61,8 @@ filepath >= 1.2, process >= 1.0, criterion >= 0.6 - ghc-options: -Wall -O2 + ghc-options: -Wall source-repository head type: git - location: git://github.com/JohnLato/posix-paths.git + location: https://github.com/JohnLato/posix-paths.git diff --git a/src/System/Posix/Directory/Traversals.hs b/src/System/Posix/Directory/Traversals.hs --- a/src/System/Posix/Directory/Traversals.hs +++ b/src/System/Posix/Directory/Traversals.hs @@ -7,6 +7,7 @@ module System.Posix.Directory.Traversals ( getDirectoryContents +, traverseDirectoryContents , allDirectoryContents , allDirectoryContents' @@ -22,25 +23,27 @@ import Control.Applicative import Control.Monad +import Control.Monad.IO.Class (liftIO) import System.Posix.FilePath (()) import System.Posix.Directory.Foreign import qualified System.Posix as Posix import System.IO.Error -import Control.Exception import qualified Data.ByteString.Char8 as BS import System.Posix.ByteString.FilePath import System.Posix.Directory.ByteString as PosixBS import System.Posix.Files.ByteString +import UnliftIO (MonadUnliftIO, withRunInIO) +import UnliftIO.Exception import System.IO.Unsafe -import Unsafe.Coerce (unsafeCoerce) import Foreign.C.Error import Foreign.C.String import Foreign.C.Types import Foreign.Marshal.Alloc (alloca,allocaBytes) import Foreign.Ptr import Foreign.Storable +import System.Posix.Directory.Internals (DirStream(DirStream),CDir ,CDirent) ---------------------------------------------------------- @@ -71,20 +74,25 @@ -- this uses traverseDirectory because it's more efficient than forcing the -- lazy version. --- | Recursively apply the 'action' to the parent directory and all +-- | Recursively apply the 'action' to the parent file or directory and all -- files/subdirectories. -- +-- Like UNIX @find@, this includes the parent file/directory! +-- +-- As for @find@, emitted file paths of subdirectories contain slashes, +-- starting with the parent directory. +-- -- This function allows for memory-efficient traversals. -traverseDirectory :: (s -> RawFilePath -> IO s) -> s -> RawFilePath -> IO s -traverseDirectory act s0 topdir = toploop +traverseDirectory :: (MonadUnliftIO m) => (s -> RawFilePath -> m s) -> s -> RawFilePath -> m s +traverseDirectory act s0 topDirOrFile = toploop where toploop = do - isDir <- isDirectory <$> getFileStatus topdir - s' <- act s0 topdir - if isDir then actOnDirContents topdir s' loop + isDir <- liftIO $ isDirectory <$> getFileStatus topDirOrFile + s' <- act s0 topDirOrFile + if isDir then actOnDirContents topDirOrFile s' loop else return s' loop typ path acc = do - isDir <- case () of + isDir <- liftIO $ case () of () | typ == dtDir -> return True | typ == dtUnknown -> isDirectory <$> getFileStatus path | otherwise -> return False @@ -92,46 +100,43 @@ then act acc path >>= \acc' -> actOnDirContents path acc' loop else act acc path -actOnDirContents :: RawFilePath +actOnDirContents :: (MonadUnliftIO m) + => RawFilePath -> b - -> (DirType -> RawFilePath -> b -> IO b) - -> IO b + -> (DirType -> RawFilePath -> b -> m b) + -> m b actOnDirContents pathRelToTop b f = - modifyIOError ((`ioeSetFileName` (BS.unpack pathRelToTop)) . - (`ioeSetLocation` "findBSTypRel")) $ do - bracket - (openDirStream pathRelToTop) - (Posix.closeDirStream) - (\dirp -> loop dirp b) - where - loop dirp b' = do - (typ,e) <- readDirEnt dirp - if (e == "") - then return b' - else do - if (e == "." || e == "..") - then loop dirp b' - else f typ (pathRelToTop e) b' >>= loop dirp + traverseDirectoryContents + (\b' (typ, e) -> f typ (pathRelToTop e) b') + b + pathRelToTop +-- | `withRunInIO` lifted to `MonadUnliftIO`. +modifyIOErrorUnliftIO :: (MonadUnliftIO m) => (IOError -> IOError) -> m a -> m a +modifyIOErrorUnliftIO f action = + withRunInIO $ \runInIO -> do + modifyIOError f (runInIO action) ---------------------------------------------------------- --- dodgy stuff -type CDir = () -type CDirent = () --- Posix doesn't export DirStream, so to re-use that type we need to use --- unsafeCoerce. It's just a newtype, so this is a legitimate usage. --- ugly trick. +-- unpacks the DirStream unpackDirStream :: DirStream -> Ptr CDir -unpackDirStream = unsafeCoerce +unpackDirStream (DirStream p) = p + packDirStream :: Ptr CDir -> DirStream -packDirStream = unsafeCoerce +packDirStream = DirStream -- the __hscore_* functions are defined in the unix package. We can import them and let -- the linker figure it out. -foreign import ccall unsafe "__hscore_readdir" +-- +-- In contrast to current `unix` we use `safe` calls for anything that +-- does file system IO, because it can take a substantial amount of time +-- on spinning disks or networked file systems, and `unsafe` calls block +-- a capability. +-- See https://github.com/haskell/unix/issues/34. +foreign import ccall safe "__hscore_readdir" c_readdir :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt foreign import ccall unsafe "__hscore_free_dirent" @@ -176,20 +181,47 @@ then return (dtUnknown,BS.empty) else throwErrno "readDirEnt" +-- | Apply the 'action' to the given directory (must be a directory), +-- without recursing into subdirectories. +-- +-- This function does filter out the @.@ and @..@ entries. +-- +-- Emitted file paths are the directory entry names, +-- thus not prefixed with the given parent directory. +-- +-- This function allows for memory-efficient traversals. +-- +-- Use this if you want to implement your own recursive subdirectory +-- traversal, deciding e.g. into which directories or symlinks to traverse. +-- +-- You SHOULD check if the obtained 'DirType' +-- is 'System.Posix.Directory.Foreign.dtUnknown' +-- (see comments in @man 3 readdir@ on @d_type@), +-- and do a 'System.Posix.Files.ByteString.getFileStatus' +-- in that case (results in @stat()@), as not all file systems +-- implement obtaining a 'DirType'. +traverseDirectoryContents :: (MonadUnliftIO m) => (s -> (DirType, RawFilePath) -> m s) -> s -> RawFilePath -> m s +traverseDirectoryContents act state path = + modifyIOErrorUnliftIO + ((`ioeSetFileName` (BS.unpack path)) . + (`ioeSetLocation` "System.Posix.Directory.Traversals.traverseDirectoryContents")) $ do + bracket + (liftIO $ PosixBS.openDirStream path) + (liftIO . PosixBS.closeDirStream) + (\dirp -> loop state dirp) + where + loop state0 dirp = do + t@(_typ,e) <- liftIO $ readDirEnt dirp + if BS.null e then return state0 else do + if (e == "." || e == "..") + then loop state0 dirp + else do + state1 <- act state0 t + loop state1 dirp + getDirectoryContents :: RawFilePath -> IO [(DirType, RawFilePath)] getDirectoryContents path = - modifyIOError ((`ioeSetFileName` (BS.unpack path)) . - (`ioeSetLocation` "System.Posix.Directory.Traversals.getDirectoryContents")) $ do - bracket - (PosixBS.openDirStream path) - PosixBS.closeDirStream - loop - where - loop dirp = do - t@(_typ,e) <- readDirEnt dirp - if BS.null e then return [] else do - es <- loop dirp - return (t:es) + fmap reverse $ traverseDirectoryContents (\l e -> pure (e:l)) [] path -- | return the canonicalized absolute pathname --