path-io 1.1.0 → 1.2.0
raw patch · 4 files changed
+354/−29 lines, 4 filesdep +containersdep +unix-compatdep ~basedep ~directorydep ~exceptions
Dependencies added: containers, unix-compat
Dependency ranges changed: base, directory, exceptions, filepath, hspec, path, path-io, temporary, time, transformers
Files
- CHANGELOG.md +14/−2
- Path/IO.hs +213/−8
- path-io.cabal +17/−14
- tests/Main.hs +110/−5
CHANGELOG.md view
@@ -1,10 +1,22 @@+## Path IO 1.2.0++* Added `walkDir` function to traverse a directory tree with a handler.++* Added `walkDirAccum` function which is like `walkDir` but also accepts an+ output writer and returns the accumulated output.++* All recursive traversal functions (existing and new) now safely handle+ directory loops due to symbolic or hard links.++* Added “since” notes to public functions in API.+ ## Path IO 1.1.0 -* Fixed bug in `copyDirRecur` when it was unable to full copy read-only+* Fixed bug in `copyDirRecur` when it was unable to fully copy read-only directories. * Added `copyDirRecur'` function that works just like `copyDirRecur`, but- does not preserve permissions.+ does not preserve directory permissions. ## Path IO 1.0.1
Path/IO.hs view
@@ -28,6 +28,10 @@ , listDirRecur , copyDirRecur , copyDirRecur'+ -- ** Walking directory trees+ , WalkAction(..)+ , walkDir+ , walkDirAccum -- ** Current working directory , getCurrentDir , setCurrentDir@@ -93,19 +97,23 @@ import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)+import Control.Monad.Trans.Writer.Lazy (runWriterT, tell) import Data.Either (lefts, rights)-import Data.Foldable (foldl') import Data.List ((\\)) import Data.Time (UTCTime) import Path import System.IO (Handle) import System.IO.Error (isDoesNotExistError)+import System.PosixCompat.Files (deviceID, fileID, getFileStatus)+import qualified Data.Set as S import qualified System.Directory as D import qualified System.FilePath as F import qualified System.IO.Temp as T #if !MIN_VERSION_base(4,8,0)-import Data.Monoid (mappend)+import Data.Monoid (Monoid) #endif ----------------------------------------------------------------------------@@ -147,6 +155,7 @@ createDir :: MonadIO m => Path b Dir -> m () createDir = liftD D.createDirectory+{-# INLINE createDir #-} -- | @'createDirIfMissing' parents dir@ creates a new directory @dir@ if it -- doesn\'t exist. If the first argument is 'True' the function will also@@ -157,14 +166,18 @@ -> Path b Dir -- ^ The path to the directory you want to make -> m () createDirIfMissing p = liftD (D.createDirectoryIfMissing p)+{-# INLINE createDirIfMissing #-} -- | Ensure that directory exists creating it and its parent directories if -- necessary. This is just a handy shortcut: -- -- > ensureDir = createDirIfMissing True+--+-- @since 0.3.1 ensureDir :: MonadIO m => Path b Dir -> m () ensureDir = createDirIfMissing True+{-# INLINE ensureDir #-} -- | @'removeDir' dir@ removes an existing directory @dir@. The -- implementation may specify additional constraints which must be satisfied@@ -206,13 +219,15 @@ removeDir :: MonadIO m => Path b Dir -> m () removeDir = liftD D.removeDirectory+{-# INLINE removeDir #-} -- | @'removeDirRecur' dir@ removes an existing directory @dir@ together -- with its contents and subdirectories. Within this directory, symbolic--- links are removed without affecting their the targets.+-- links are removed without affecting their targets. removeDirRecur :: MonadIO m => Path b Dir -> m () removeDirRecur = liftD D.removeDirectoryRecursive+{-# INLINE removeDirRecur #-} -- |@'renameDir' old new@ changes the name of an existing directory from -- @old@ to @new@. If the @new@ directory already exists, it is atomically@@ -265,6 +280,7 @@ -> Path b1 Dir -- ^ New name -> m () renameDir = liftD2 D.renameDirectory+{-# INLINE renameDir #-} -- | @'listDir' dir@ returns a list of /all/ entries in @dir@ without the -- special entries (@.@ and @..@). Entries are not sorted.@@ -316,9 +332,8 @@ listDirRecur :: (MonadIO m, MonadThrow m) => Path b Dir -- ^ Directory to list -> m ([Path Abs Dir], [Path Abs File]) -- ^ Sub-directories and files-listDirRecur path = do- items <- listDir path- foldl' mappend items `liftM` mapM listDirRecur (fst items)+listDirRecur = walkDirAccum Nothing (\_ d f -> return (d, f))+{-# INLINE listDirRecur #-} -- | Copy directory recursively. This is not smart about symbolic links, but -- tries to preserve permissions when possible. If destination directory@@ -331,16 +346,20 @@ -> Path b1 Dir -- ^ Destination -> m () copyDirRecur = copyDirRecurGen True+{-# INLINE copyDirRecur #-} -- | The same as 'copyDirRecur', but it does not preserve directory -- permissions. This may be useful, for example, if directory you want to--- copy is “read-only”, but you want your copy to editable.+-- copy is “read-only”, but you want your copy to be editable.+--+-- @since 1.1.0 copyDirRecur' :: (MonadIO m, MonadCatch m) => Path b0 Dir -- ^ Source -> Path b1 Dir -- ^ Destination -> m () copyDirRecur' = copyDirRecurGen False+{-# INLINE copyDirRecur' #-} -- | Generic version of 'copyDirRecur'. The first argument controls whether -- to preserve directory permissions or not.@@ -370,6 +389,124 @@ zipWithM_ (\s d -> ignoringIOErrors $ copyPermissions s d) dirs tdirs ----------------------------------------------------------------------------+-- Walking directory trees++-- Recursive directory walk functionality, with a flexible API and avoidance+-- of loops. Following are some notes on the design.+--+-- Callback handler API:+--+-- The callback handler interface is designed to be highly flexible. There are+-- two possible alternative ways to control the traversal:+-- * In the context of the parent dir, decide which subdirs to descend into.+-- * In the context of the subdir, decide whether to traverse the subdir or not.+--+-- We choose the first approach here since it is more flexible and can achieve+-- everything that the second one can. The additional benefit with this is that+-- we can use the parent dir context efficiently instead of each child looking+-- at the parent context independently.+--+-- To control which subdirs to descend we use a WalkExclude API instead of a+-- WalkInclude type of API so that the handlers cannot accidentally ask us to+-- descend a dir which is not a subdir of the directory being walked.+--+-- Avoiding Traversal Loops:+--+-- There can be loops in the path being traversed due to subdirectory symlinks+-- or filesystem corruptions can cause loops by creating directory hardlinks.+-- Also, if the filesystem is changing while we are traversing then we might+-- be going in loops due to the changes.+--+-- We record the path we are coming from to detect the loops. If we end up+-- traversing the same directory again we are in a loop.++-- | Action returned by the traversal handler function. The action decides how+-- the traversal will proceed further.+--+-- @since 1.2.0++data WalkAction+ = WalkFinish -- ^ Finish the entire walk altogether+ | WalkExclude [Path Abs Dir] -- ^ List of sub-directories to exclude from+ -- descending++-- | Traverse a directory tree, calling a handler function at each directory+-- node traversed. The absolute paths of the parent directory, sub-directories+-- and the files in the directory are provided as arguments to the handler.+--+-- Detects and silently avoids any traversal loops in the directory tree.+--+-- @since 1.2.0++walkDir+ :: (MonadIO m, MonadThrow m)+ => (Path Abs Dir -> [Path Abs Dir] -> [Path Abs File] -> m WalkAction)+ -- ^ Handler (@dir -> subdirs -> files -> 'WalkAction'@)+ -> Path b Dir+ -- ^ Directory where traversal begins+ -> m ()+walkDir handler topdir =+ makeAbsolute topdir >>= walkAvoidLoop S.empty >> return ()+ where+ walkAvoidLoop traversed curdir = do+ mRes <- checkLoop traversed curdir+ case mRes of+ Nothing -> return $ Just ()+ Just traversed' -> walktree traversed' curdir++ -- use Maybe monad to abort any further traversal if any of the+ -- handler calls returns WalkFinish+ walktree traversed curdir = do+ (subdirs, files) <- listDir curdir+ action <- handler curdir subdirs files+ case action of+ WalkFinish -> return Nothing+ WalkExclude xdirs ->+ case subdirs \\ xdirs of+ [] -> return $ Just ()+ ds -> runMaybeT $ mapM_ (MaybeT . walkAvoidLoop traversed) ds++ checkLoop traversed dir = do+ st <- liftIO $ getFileStatus (toFilePath dir)+ let ufid = (deviceID st, fileID st)++ -- check for loop, have we already traversed this dir?+ return $ if S.member ufid traversed+ then Nothing+ else Just (S.insert ufid traversed)++-- | Similar to 'walkDir' but accepts a 'Monoid' returning, output+-- writer as well. Values returned by the output writer invocations are+-- accumulated and returned.+--+-- Both, the descend handler as well as the output writer can be used for side+-- effects but keep in mind that the output writer runs before the descend+-- handler.+--+-- @since 1.2.0++walkDirAccum+ :: (MonadIO m, MonadThrow m, Monoid o)+ => Maybe (Path Abs Dir -> [Path Abs Dir] -> [Path Abs File] -> m WalkAction)+ -- ^ Descend handler (@dir -> subdirs -> files -> 'WalkAction'@),+ -- descend the whole tree if omitted+ -> (Path Abs Dir -> [Path Abs Dir] -> [Path Abs File] -> m o)+ -- ^ Output writer (@dir -> subdirs -> files -> o@)+ -> Path b Dir+ -- ^ Directory where traversal begins+ -> m o+ -- ^ Accumulation of outputs generated by the output writer invocations+walkDirAccum dHandler writer topdir =+ liftM snd . runWriterT $ walkDir handler topdir+ where+ handler dir subdirs files = do+ res <- lift $ writer dir subdirs files+ tell res+ case dHandler of+ Just h -> lift $ h dir subdirs files+ Nothing -> return (WalkExclude [])++---------------------------------------------------------------------------- -- Current working directory -- | Obtain the current working directory as an absolute path.@@ -401,6 +538,7 @@ getCurrentDir :: (MonadIO m, MonadThrow m) => m (Path Abs Dir) getCurrentDir = liftIO D.getCurrentDirectory >>= parseAbsDir+{-# INLINE getCurrentDir #-} -- | Change the working directory to the given path. --@@ -437,6 +575,7 @@ setCurrentDir :: MonadIO m => Path b Dir -> m () setCurrentDir = liftD D.setCurrentDirectory+{-# INLINE setCurrentDir #-} -- | Run an 'IO' action with the given working directory and restore the -- original working directory afterwards, even if the given action fails due@@ -476,6 +615,7 @@ getHomeDir :: (MonadIO m, MonadThrow m) => m (Path Abs Dir) getHomeDir = liftIO D.getHomeDirectory >>= resolveDir'+{-# INLINE getHomeDir #-} -- | Obtain the path to a special directory for storing user-specific -- application data (traditional Unix location).@@ -505,6 +645,7 @@ => String -- ^ Name of application (used in path construction) -> m (Path Abs Dir) getAppUserDataDir = (>>= parseAbsDir) . liftIO . D.getAppUserDataDirectory+{-# INLINE getAppUserDataDir #-} -- | Returns the current user's document directory. --@@ -527,6 +668,7 @@ getUserDocsDir :: (MonadIO m, MonadThrow m) => m (Path Abs Dir) getUserDocsDir = liftIO D.getUserDocumentsDirectory >>= parseAbsDir+{-# INLINE getUserDocsDir #-} -- | Returns the current directory for temporary files. --@@ -556,6 +698,7 @@ getTempDir :: (MonadIO m, MonadThrow m) => m (Path Abs Dir) getTempDir = liftIO D.getTemporaryDirectory >>= resolveDir'+{-# INLINE getTempDir #-} ---------------------------------------------------------------------------- -- Path transformation@@ -569,6 +712,8 @@ -- | Closed type family describing how to get relative version of given -- 'Path'.+--+-- @since 0.3.0 type family RelPath path where RelPath (Path b File) = Path Rel File@@ -624,6 +769,8 @@ => path -> m (AbsPath path) -- | Make a path relative to given directory.+ --+ -- @since 0.3.0 makeRelative :: MonadThrow m => Path Abs Dir -- ^ Base directory@@ -631,24 +778,36 @@ -> m (RelPath path) -- | Make a path relative to current working directory.+ --+ -- @since 0.3.0 makeRelativeToCurrentDir :: (MonadIO m, MonadThrow m) => path -> m (RelPath path) instance AnyPath (Path b File) where canonicalizePath = liftD D.canonicalizePath >=> parseAbsFile+ {-# INLINE canonicalizePath #-} makeAbsolute = liftD D.makeAbsolute >=> parseAbsFile+ {-# INLINE makeAbsolute #-} makeRelative b p = parseRelFile (F.makeRelative (toFilePath b) (toFilePath p))+ {-# INLINE makeRelative #-} makeRelativeToCurrentDir p = getCurrentDir >>= flip makeRelative p+ {-# INLINE makeRelativeToCurrentDir #-} instance AnyPath (Path b Dir) where canonicalizePath = liftD D.canonicalizePath >=> parseAbsDir+ {-# INLINE canonicalizePath #-} makeAbsolute = liftD D.makeAbsolute >=> parseAbsDir+ {-# INLINE makeAbsolute #-} makeRelative b p = parseRelDir (F.makeRelative (toFilePath b) (toFilePath p))+ {-# INLINE makeRelative #-} makeRelativeToCurrentDir p = getCurrentDir >>= flip makeRelative p+ {-# INLINE makeRelativeToCurrentDir #-} -- | Append stringly-typed path to an absolute path and then canonicalize -- it.+--+-- @since 0.3.0 resolveFile :: (MonadIO m, MonadThrow m) => Path Abs Dir -- ^ Base directory@@ -656,15 +815,21 @@ -> m (Path Abs File) resolveFile b p = f (toFilePath b F.</> p) >>= parseAbsFile where f = liftIO . D.canonicalizePath+{-# INLINE resolveFile #-} -- | The same as 'resolveFile', but uses current working directory.+--+-- @since 0.3.0 resolveFile' :: (MonadIO m, MonadThrow m) => FilePath -- ^ Path to resolve -> m (Path Abs File) resolveFile' p = getCurrentDir >>= flip resolveFile p+{-# INLINE resolveFile' #-} -- | The same as 'resolveFile', but for directories.+--+-- @since 0.3.0 resolveDir :: (MonadIO m, MonadThrow m) => Path Abs Dir -- ^ Base directory@@ -672,13 +837,17 @@ -> m (Path Abs Dir) resolveDir b p = f (toFilePath b F.</> p) >>= parseAbsDir where f = liftIO . D.canonicalizePath+{-# INLINE resolveDir #-} -- | The same as 'resolveDir', but uses current working directory.+--+-- @since 0.3.0 resolveDir' :: (MonadIO m, MonadThrow m) => FilePath -- ^ Path to resolve -> m (Path Abs Dir) resolveDir' p = getCurrentDir >>= flip resolveDir p+{-# INLINE resolveDir' #-} ---------------------------------------------------------------------------- -- Actions on files@@ -716,6 +885,7 @@ removeFile :: MonadIO m => Path b File -> m () removeFile = liftD D.removeFile+{-# INLINE removeFile #-} -- | @'renameFile' old new@ changes the name of an existing file system -- object from /old/ to /new/. If the /new/ object already exists, it is@@ -763,6 +933,7 @@ -> Path b1 File -- ^ New location -> m () renameFile = liftD2 D.renameFile+{-# INLINE renameFile #-} -- | @'copyFile' old new@ copies the existing file from @old@ to @new@. If -- the @new@ file already exists, it is atomically replaced by the @old@@@ -774,6 +945,7 @@ -> Path b1 File -- ^ Where to put copy -> m () copyFile = liftD2 D.copyFile+{-# INLINE copyFile #-} -- | Given an executable file name, search for such file in the directories -- listed in system @PATH@. The returned value is the path to the found@@ -794,6 +966,7 @@ => Path Rel File -- ^ Executable file name -> m (Maybe (Path Abs File)) -- ^ Path to found executable findExecutable = liftM (>>= parseAbsFile) . liftD D.findExecutable+{-# INLINE findExecutable #-} -- | Search through the given set of directories for the given file. @@ -817,6 +990,7 @@ -> Path Rel File -- ^ Filename of interest -> m [Path Abs File] -- ^ Absolute paths to all found files findFiles = findFilesWith (const (return True))+{-# INLINE findFiles #-} -- | Search through the given set of directories for the given file and with -- the given property (usually permissions) and return a list of paths where@@ -843,6 +1017,8 @@ -- -- Creates a new temporary file inside the given directory, making use of -- the template. The temporary file is deleted after use.+--+-- @since 0.2.0 withTempFile :: (MonadIO m, MonadMask m) => Path b Dir -- ^ Directory to create the file in@@ -858,6 +1034,8 @@ -- -- Creates a new temporary directory inside the given directory, making use -- of the template. The temporary directory is deleted after use.+--+-- @since 0.2.0 withTempDir :: (MonadIO m, MonadMask m) => Path b Dir -- ^ Directory to create the file in@@ -873,6 +1051,8 @@ -- -- Behaves exactly the same as 'withTempFile', except that the parent -- temporary directory will be that returned by 'getTempDir'.+--+-- @since 0.2.0 withSystemTempFile :: (MonadIO m, MonadMask m) => String -- ^ File name template, see 'openTempFile'@@ -886,6 +1066,8 @@ -- -- Behaves exactly the same as 'withTempDir', except that the parent -- temporary directory will be that returned by 'getTempDir'.+--+-- @since 0.2.0 withSystemTempDir :: (MonadIO m, MonadMask m) => String -- ^ Directory name template, see 'openTempFile'@@ -908,6 +1090,8 @@ -- prevent this attack, but note that @O_EXCL@ is sometimes not supported on -- NFS filesystems, so if you rely on this behaviour it is best to use local -- filesystems only.+--+-- @since 0.2.0 openTempFile :: (MonadIO m, MonadThrow m) => Path b Dir -- ^ Directory to create file in@@ -927,6 +1111,8 @@ -- usual under Microsoft operating systems, text mode treats control-Z as -- EOF. Binary mode turns off all special treatment of end-of-line and -- end-of-file characters.+--+-- @since 0.2.0 openBinaryTempFile :: (MonadIO m, MonadThrow m) => Path b Dir -- ^ Directory to create file in@@ -942,6 +1128,8 @@ -- -- The directory is created with permissions such that only the current user -- can read\/write it.+--+-- @since 0.2.0 createTempDir :: (MonadIO m, MonadThrow m) => Path b Dir -- ^ Directory to create file in@@ -958,6 +1146,7 @@ doesFileExist :: MonadIO m => Path b File -> m Bool doesFileExist = liftD D.doesFileExist+{-# INLINE doesFileExist #-} -- | The operation 'doesDirExist' returns 'True' if the argument file exists -- and is either a directory or a symbolic link to a directory, and 'False'@@ -965,6 +1154,7 @@ doesDirExist :: MonadIO m => Path b Dir -> m Bool doesDirExist = liftD D.doesDirectoryExist+{-# INLINE doesDirExist #-} -- | Check if there is a file or directory on specified path. @@ -978,16 +1168,22 @@ -- | If argument of the function throws a -- 'System.IO.Error.doesNotExistErrorType', 'Nothing' is returned (other -- exceptions propagate). Otherwise the result is returned inside a 'Just'.+--+-- @since 0.3.0 forgivingAbsence :: (MonadIO m, MonadCatch m) => m a -> m (Maybe a) forgivingAbsence f = catchIf isDoesNotExistError (Just `liftM` f) (const $ return Nothing)+{-# INLINE forgivingAbsence #-} -- | The same as 'forgivingAbsence', but ignores result.+--+-- @since 0.3.1 ignoringAbsence :: (MonadIO m, MonadCatch m) => m a -> m () ignoringAbsence = liftM (const ()) . forgivingAbsence+{-# INLINE ignoringAbsence #-} ---------------------------------------------------------------------------- -- Permissions@@ -1004,6 +1200,7 @@ getPermissions :: MonadIO m => Path b t -> m D.Permissions getPermissions = liftD D.getPermissions+{-# INLINE getPermissions #-} -- | The 'setPermissions' operation sets the permissions for the file or -- directory.@@ -1017,6 +1214,7 @@ setPermissions :: MonadIO m => Path b t -> D.Permissions -> m () setPermissions = liftD2' D.setPermissions+{-# INLINE setPermissions #-} -- | Set permissions for the object found on second given path so they match -- permissions of the object on the first path.@@ -1026,6 +1224,7 @@ -> Path b1 t1 -- ^ What to modify -> m () copyPermissions = liftD2 D.copyPermissions+{-# INLINE copyPermissions #-} ---------------------------------------------------------------------------- -- Timestamps@@ -1047,6 +1246,7 @@ getAccessTime :: MonadIO m => Path b t -> m UTCTime getAccessTime = liftD D.getAccessTime+{-# INLINE getAccessTime #-} -- | Change the time at which the file or directory was last accessed. --@@ -1072,6 +1272,7 @@ setAccessTime :: MonadIO m => Path b t -> UTCTime -> m () setAccessTime = liftD2' D.setAccessTime+{-# INLINE setAccessTime #-} -- | Change the time at which the file or directory was last modified. --@@ -1097,7 +1298,7 @@ setModificationTime :: MonadIO m => Path b t -> UTCTime -> m () setModificationTime = liftD2' D.setAccessTime-+{-# INLINE setModificationTime #-} #endif -- | Obtain the time at which the file or directory was last modified.@@ -1115,6 +1316,7 @@ getModificationTime :: MonadIO m => Path b t -> m UTCTime getModificationTime = liftD D.getModificationTime+{-# INLINE getModificationTime #-} ---------------------------------------------------------------------------- -- Helpers@@ -1127,6 +1329,7 @@ -> Path b t -- ^ 'Path' argument -> m a -- ^ Lifted action liftD m = liftIO . m . toFilePath+{-# INLINE liftD #-} -- | Similar to 'liftD' for functions with arity 2. @@ -1136,6 +1339,7 @@ -> Path b1 t1 -- ^ Second 'Path' argument -> m a liftD2 m a b = liftIO $ m (toFilePath a) (toFilePath b)+{-# INLINE liftD2 #-} -- | Similar to 'liftD2', but allows to pass second argument of arbitrary -- type.@@ -1146,6 +1350,7 @@ -> v -- ^ Second argument -> m a liftD2' m a v = liftIO $ m (toFilePath a) v+{-# INLINE liftD2' #-} -- | Perform specified action ignoring IO exceptions it may throw.
path-io.cabal view
@@ -31,7 +31,7 @@ -- POSSIBILITY OF SUCH DAMAGE. name: path-io-version: 1.1.0+version: 1.2.0 cabal-version: >= 1.10 license: BSD3 license-file: LICENSE.md@@ -52,14 +52,16 @@ default: False library- build-depends: base >= 4.7 && < 5- , directory >= 1.2.2.0- , exceptions >= 0.8- , filepath >= 1.2- , path >= 0.5- , temporary >= 1.1- , time >= 1.4- , transformers >= 0.3+ build-depends: base >= 4.7 && < 5.0+ , containers+ , directory >= 1.2.2.0 && < 1.3+ , exceptions >= 0.8 && < 0.9+ , filepath >= 1.2 && < 1.5+ , path >= 0.5 && < 0.6+ , temporary >= 1.1 && < 1.3+ , time >= 1.4 && < 1.7+ , transformers >= 0.3 && < 0.6+ , unix-compat exposed-modules: Path.IO if flag(dev) ghc-options: -Wall -Werror@@ -75,11 +77,12 @@ ghc-options: -Wall -Werror else ghc-options: -O2 -Wall- build-depends: base >= 4.7 && < 5- , exceptions >= 0.8- , hspec >= 2.0- , path >= 0.5- , path-io >= 1.1.0+ build-depends: base >= 4.7 && < 5.0+ , exceptions >= 0.8 && < 0.9+ , hspec >= 2.0 && < 3.0+ , path >= 0.5 && < 0.6+ , path-io >= 1.2.0+ , unix-compat default-language: Haskell2010 source-repository head
tests/Main.hs view
@@ -42,6 +42,7 @@ import Path.IO import Test.Hspec import System.Environment+import System.PosixCompat.Files #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>))@@ -50,11 +51,19 @@ main :: IO () main = hspec . around withSandbox $ do beforeWith populatedDir $ do- describe "listDir" listDirSpec- describe "listDirRecur" listDirRecurSpec- describe "copyDirRecur" copyDirRecurSpec- describe "copyDirRecur'" copyDirRecur'Spec- describe "findFile" findFileSpec+ describe "listDir" listDirSpec+ describe "listDirRecur" listDirRecurSpec+ describe "listDirRecurWith" listDirRecurWithSpec+ describe "walkDir Finish" walkDirFinishSpec+ describe "copyDirRecur" copyDirRecurSpec+ describe "copyDirRecur'" copyDirRecur'Spec+ describe "findFile" findFileSpec+ -- This test may fail on windows as unix-compat does not implement+ -- createSymbolicLink.+#ifndef mingw32_HOST_OS+ beforeWith populatedCyclicDir $+ describe "listDirRecur Cyclic" listDirRecurCyclicSpec+#endif describe "getCurrentDir" getCurrentDirSpec describe "setCurrentDir" setCurrentDirSpec describe "withCurrentDir" withCurrentDirSpec@@ -69,6 +78,46 @@ listDirRecurSpec = it "lists directory recursively" $ \dir -> getDirStructure listDirRecur dir `shouldReturn` populatedDirStructure +listDirRecurWithSpec :: SpecWith (Path Abs Dir)+listDirRecurWithSpec =+ it "lists directory recursively using predicates" $ \dir ->+ getDirStructure (listDirRecurWith+ (return . ($(mkRelDir "c") /=) . dirname)+ (return . ($(mkRelFile "two.txt") /=) . filename)) dir+ `shouldReturn` populatedDirRecurWith++listDirRecurWith+ :: (Path Abs Dir -> IO Bool) -- ^ Dir match predicate+ -> (Path Abs File -> IO Bool) -- ^ File match predicate+ -> Path Abs Dir -- ^ Top dir to traverse+ -> IO ([Path Abs Dir], [Path Abs File]) -- ^ Matched subdirs and files+listDirRecurWith dirPred filePred =+ walkDirAccum Nothing $ \_ d f -> do+ d' <- filterM dirPred d+ f' <- filterM filePred f+ return (d', f')++listDirRecurCyclicSpec :: SpecWith (Path Abs Dir)+listDirRecurCyclicSpec =+ it "lists directory trees having traversal cycles" $ \dir ->+ getDirStructure listDirRecur dir `shouldReturn` populatedCyclicDirStructure++-- | walkDir with a Finish handler may have unpredictable output depending on+-- the order of traversal. The only guarantee is that we will finish only after+-- we find the directory "c". Though if we test only for the presence of "c" we+-- are not really testing if we indeed cut the traversal short.++walkDirFinishSpec :: SpecWith (Path Abs Dir)+walkDirFinishSpec =+ it "Finishes only after finding what it is looking for" $ \dir -> do+ (d, _) <- getDirStructure (walkDirAccum (Just dHandler) writer) dir+ map dirname d `shouldContain` [$(mkRelDir "c")]+ where dHandler p _ _+ | dirname p == $(mkRelDir "c") = return WalkFinish+ | otherwise = return (WalkExclude [])++ writer _ d f = return (d, f)+ copyDirRecurSpec :: SpecWith (Path Abs Dir) copyDirRecurSpec = do context "when source directory is editable" $@@ -199,6 +248,48 @@ ] ) +-- | Create a directory structure which has cycles in it due to directory+-- symbolic links.+--+-- 1) Mutual cycles between two directory trees. If we traverse a or c we+-- will get into the same cycle:+ -- a/(b -> c), c/(d -> a)+ -- c/(d -> a), a/(b -> c)+-- 2) Cycle with own ancestor+ -- e/f/(g -> e)++populatedCyclicDirStructure :: ([Path Rel Dir], [Path Rel File])+populatedCyclicDirStructure =+ ( [+ $(mkRelDir "a")+ , $(mkRelDir "a/b") -- b points to c+ , $(mkRelDir "a/b/d") -- because b is same as c+ , $(mkRelDir "c")+ , $(mkRelDir "c/d") -- d points to a+ , $(mkRelDir "c/d/b") -- because d is same as a+ , $(mkRelDir "e")+ , $(mkRelDir "e/f")+ , $(mkRelDir "e/f/g") -- g points to e+ ]+ , []+ )++-- | Created the objects described in 'populatedCyclicDirStructure'.+-- Return path to that directory.++populatedCyclicDir :: Path Abs Dir -> IO (Path Abs Dir)+populatedCyclicDir root = do+ let pdir = root </> $(mkRelDir "pdir")+ withinSandbox = (pdir </>)+ ensureDir pdir+ ensureDir $ withinSandbox $(mkRelDir "a")+ ensureDir $ withinSandbox $(mkRelDir "c")+ ensureDir $ withinSandbox $(mkRelDir "e/f")+ createSymbolicLink "../c" (toFilePath $ withinSandbox $(mkRelFile "a/b"))+ createSymbolicLink "../a" (toFilePath $ withinSandbox $(mkRelFile "c/d"))+ createSymbolicLink "../../e" (toFilePath $ withinSandbox $(mkRelFile "e/f/g"))+ return pdir+ -- | Top-level structure of populated directory as it should be scanned by -- the 'listDir' function. @@ -208,5 +299,19 @@ , $(mkRelDir "b") ] , [ $(mkRelFile "one.txt")+ ]+ )++-- | Structure of populated directory as it should be scanned by+-- 'listDirRecurWith' function using predicates to filter out dir 'c' and the+-- file 'two.txt'++populatedDirRecurWith :: ([Path Rel Dir], [Path Rel File])+populatedDirRecurWith =+ ( [ $(mkRelDir "a")+ , $(mkRelDir "b")+ ]+ , [ $(mkRelFile "b/c/three.txt")+ , $(mkRelFile "one.txt") ] )