diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,21 @@ +## Path IO 1.3.0 + +* Change the default behavior of recursive traversal APIs to not follow + symbolic links. The change affects the following functions: + `listDirRecur`, `copyDirRecur`, and `copyDirRecur'`. + +* Add `isSymlink` which allows to test whether a path is a symbolic link. + +* Move the type functions `AbsPath` and `RelPath` to the `AnyPath` type + class (previously they were standalone closed type families, now they are + associated types of `AnyPath`). + +* Improved the documentation and metadata. + +## Path IO 1.2.3 + +* Allowed `time-1.7`. + ## Path IO 1.2.2 * Fixed a bug in `setModificationTime` function that previously called diff --git a/Path/IO.hs b/Path/IO.hs --- a/Path/IO.hs +++ b/Path/IO.hs @@ -3,13 +3,14 @@ -- Copyright : © 2016–2017 Mark Karpov -- License : BSD 3 clause -- --- Maintainer : Mark Karpov +-- Maintainer : Mark Karpov -- Stability : experimental -- Portability : portable -- --- This module provides interface to "System.Directory" for users of "Path" --- module. It also implements commonly used primitives like recursive --- scanning and copying of directories. +-- This module provides an interface to "System.Directory" for users of the +-- "Path" module. It also implements commonly used primitives like recursive +-- scanning and copying of directories, working with temporary +-- files\/directories, etc. {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} @@ -46,8 +47,6 @@ , getXdgDir #endif -- * Path transformation - , AbsPath - , RelPath , AnyPath (..) , resolveFile , resolveFile' @@ -61,6 +60,8 @@ , findFile , findFiles , findFilesWith + -- * Symbolic links + , isSymlink -- * Temporary files and directories , withTempFile , withTempDir @@ -110,15 +111,15 @@ 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 +import qualified System.PosixCompat.Files as P + #if MIN_VERSION_directory(1,2,3) import System.Directory (XdgDirectory) #endif -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 (Monoid) #endif @@ -151,10 +152,9 @@ -- There is no path to the directory. -- @[ENOENT, ENOTDIR]@ -- --- * 'ResourceExhausted' --- Insufficient resources (virtual memory, process file descriptors, --- physical disk space, etc.) are available to perform the operation. --- @[EDQUOT, ENOSPC, ENOMEM, EMLINK]@ +-- * 'ResourceExhausted' Insufficient resources (virtual memory, process +-- file descriptors, physical disk space, etc.) are available to perform the +-- operation. @[EDQUOT, ENOSPC, ENOMEM, EMLINK]@ -- -- * 'InappropriateType' -- The path refers to an existing non-directory object. @@ -162,10 +162,9 @@ 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 +-- doesn't exist. If the first argument is 'True' the function will also -- create all parent directories if they are missing. createDirIfMissing :: MonadIO m @@ -173,10 +172,9 @@ -> 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: +-- | Ensure that a directory exists creating it and its parent directories +-- if necessary. This is just a handy shortcut: -- -- > ensureDir = createDirIfMissing True -- @@ -184,12 +182,11 @@ 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 -- before a directory can be removed (e.g. the directory has to be empty, or --- may not be in use by other processes). It is not legal for an +-- may not be in use by other processes). It is not legal for an -- implementation to partially remove a directory unless the entire -- directory is removed. A conformant implementation need not support -- directory removal in all situations (e.g. removal of the root directory). @@ -226,15 +223,13 @@ 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 +-- with its contents and sub-directories. Within this directory, symbolic -- 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 @@ -287,7 +282,6 @@ -> 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. @@ -332,44 +326,52 @@ else Right `liftM` parseAbsFile ipath return (lefts items, rights items) --- | Similar to 'listDir', but recursively traverses every sub-directory, --- and collects all files and directories. This can fail with the same --- exceptions as 'listDir'. +-- | Similar to 'listDir', but recursively traverses every sub-directory +-- /excluding symbolic links/, and returns all files and directories found. +-- This can fail with the same exceptions as 'listDir'. +-- +-- __Note__: before version /1.3.0/, this function followed symlinks. listDirRecur :: (MonadIO m, MonadThrow m) - => Path b Dir -- ^ Directory to list + => Path b Dir -- ^ Directory to list -> m ([Path Abs Dir], [Path Abs File]) -- ^ Sub-directories and files -listDirRecur = walkDirAccum Nothing (\_ d f -> return (d, f)) -{-# INLINE listDirRecur #-} +listDirRecur = walkDirAccum (Just excludeSymlinks) (\_ d f -> return (d, f)) + where excludeSymlinks _ subdirs _ = + liftM WalkExclude (filterM isSymlink subdirs) --- | Copy directory recursively. This is not smart about symbolic links, but --- tries to preserve permissions when possible. If destination directory --- already exists, new files and sub-directories will complement its --- structure, possibly overwriting old files if they happen to have the same --- name as the new ones. +-- | Copies a directory recursively. It /does not/ follow symbolic links and +-- preserves permissions when possible. If the destination directory already +-- exists, new files and sub-directories complement its structure, possibly +-- overwriting old files if they happen to have the same name as the new +-- ones. +-- +-- __Note__: before version /1.3.0/, this function followed symlinks. copyDirRecur :: (MonadIO m, MonadCatch m) => Path b0 Dir -- ^ Source -> 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 be editable. +-- | The same as 'copyDirRecur', but it /does not/ preserve directory +-- permissions. This may be useful, for example, if the directory you want +-- to copy is “read-only”, but you want your copy to be editable. -- -- @since 1.1.0 +-- +-- __Note__: before version /1.3.0/, this function followed symlinks. 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. +-- to preserve directory permissions or not. /Does not/ follow symbolic +-- links. +-- +-- __Note__: before version /1.3.0/, this function followed symlinks. copyDirRecurGen :: (MonadIO m, MonadCatch m) => Bool -- ^ Should we preserve directory permissions? @@ -405,30 +407,31 @@ -- -- 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. +-- 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. +-- 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. +-- 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. +-- | Action returned by the traversal handler function. The action controls +-- how the traversal will proceed. -- -- @since 1.2.0 @@ -436,13 +439,16 @@ = WalkFinish -- ^ Finish the entire walk altogether | WalkExclude [Path Abs Dir] -- ^ List of sub-directories to exclude from -- descending + deriving (Eq, Show) --- | Traverse a directory tree using depth first pre-order traversal, 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. +-- | Traverse a directory tree using depth first pre-order traversal, +-- 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. +-- The function is capable of detecting and avoiding traversal loops in the +-- directory tree. Note that the traversal follows symlinks by default, an +-- appropriate traversal handler can be used to avoid that when necessary. -- -- @since 1.2.0 @@ -475,21 +481,21 @@ ds -> runMaybeT $ mapM_ (MaybeT . walkAvoidLoop traversed) ds checkLoop traversed dir = do - st <- liftIO $ getFileStatus (toFilePath dir) - let ufid = (deviceID st, fileID st) + st <- liftIO $ P.getFileStatus (toFilePath dir) + let ufid = (P.deviceID st, P.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. +-- | 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. +-- 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 @@ -504,7 +510,7 @@ -- ^ Directory where traversal begins -> m o -- ^ Accumulation of outputs generated by the output writer invocations -walkDirAccum dHandler writer topdir = execWriterT $ walkDir handler topdir +walkDirAccum dHandler writer topdir = execWriterT (walkDir handler topdir) where handler dir subdirs files = do res <- lift $ writer dir subdirs files @@ -545,7 +551,6 @@ getCurrentDir :: (MonadIO m, MonadThrow m) => m (Path Abs Dir) getCurrentDir = liftIO D.getCurrentDirectory >>= parseAbsDir -{-# INLINE getCurrentDir #-} -- | Change the working directory to the given path. -- @@ -582,7 +587,6 @@ 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 @@ -601,7 +605,7 @@ ---------------------------------------------------------------------------- -- Pre-defined directories --- | Returns the current user's home directory. +-- | Return the current user's home directory. -- -- The directory returned is expected to be writable by the current user, -- but note that it isn't generally considered good practice to store @@ -622,7 +626,6 @@ 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). @@ -652,9 +655,8 @@ => 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. +-- | Return the current user's document directory. -- -- The directory returned is expected to be writable by the current user, -- but note that it isn't generally considered good practice to store @@ -675,9 +677,8 @@ getUserDocsDir :: (MonadIO m, MonadThrow m) => m (Path Abs Dir) getUserDocsDir = liftIO D.getUserDocumentsDirectory >>= parseAbsDir -{-# INLINE getUserDocsDir #-} --- | Returns the current directory for temporary files. +-- | Return the current directory for temporary files. -- -- On Unix, 'getTempDir' returns the value of the @TMPDIR@ environment -- variable or \"\/tmp\" if the variable isn\'t defined. On Windows, the @@ -705,7 +706,6 @@ getTempDir :: (MonadIO m, MonadThrow m) => m (Path Abs Dir) getTempDir = liftIO D.getTemporaryDirectory >>= resolveDir' -{-# INLINE getTempDir #-} #if MIN_VERSION_directory(1,2,3) -- | Obtain the paths to special directories for storing user-specific @@ -731,32 +731,25 @@ -- ^ A relative path that is appended to the path; if 'Nothing', the -- base path is returned -> m (Path Abs Dir) -getXdgDir xdgDir suffix = liftIO (D.getXdgDirectory xdgDir $ maybe "" toFilePath suffix) >>= parseAbsDir -{-# INLINE getXdgDir #-} +getXdgDir xdgDir suffix = + liftIO (D.getXdgDirectory xdgDir $ maybe "" toFilePath suffix) >>= parseAbsDir #endif ---------------------------------------------------------------------------- -- Path transformation --- | Closed type family describing how to get absolute version of given --- 'Path'. +-- | Class of things ('Path's) that can be canonicalized, made absolute, and +-- made relative to a some base directory. -type family AbsPath path where - AbsPath (Path b File) = Path Abs File - AbsPath (Path b Dir) = Path Abs Dir +class AnyPath path where --- | Closed type family describing how to get relative version of given --- 'Path'. --- --- @since 0.3.0 + -- | Type of absolute version of the given @path@. -type family RelPath path where - RelPath (Path b File) = Path Rel File - RelPath (Path b Dir) = Path Rel Dir + type AbsPath path :: * --- | Class of things ('Path's) that can be canonicalized and made absolute. + -- | Type of relative version of the given @path@. -class AnyPath path where + type RelPath path :: * -- | Make a path absolute and remove as many indirections from it as -- possible. Indirections include the two special directories @.@ and @@ -767,43 +760,41 @@ -- instead. Most programs need not care about whether a path contains -- symbolic links. -- - -- Due to the fact that symbolic links and @..@ are dependent on the state - -- of the existing filesystem, the function can only make a conservative, + -- Due to the fact that symbolic links are dependent on the state of the + -- existing filesystem, the function can only make a conservative, -- best-effort attempt. Nevertheless, if the input path points to an -- existing file or directory, then the output path shall also point to -- the same file or directory. -- - -- Formally, symbolic links and @..@ are removed from the longest prefix - -- of the path that still points to an existing file. The function is not - -- atomic, therefore concurrent changes in the filesystem may lead to - -- incorrect results. + -- Formally, symbolic links are removed from the longest prefix of the + -- path that still points to an existing file. The function is not atomic, + -- therefore concurrent changes in the filesystem may lead to incorrect + -- results. -- -- (Despite the name, the function does not guarantee canonicity of the -- returned path due to the presence of hard links, mount points, etc.) -- - -- Similar to 'normalise', an empty path is equivalent to the current - -- directory. - -- -- /Known bug(s)/: on Windows, the function does not resolve symbolic -- links. -- - -- Please note that before version 1.2.3.0 of @directory@ package, this - -- function had unpredictable behavior on non-existent paths. + -- Please note that before version 1.2.3.0 of the @directory@ package, + -- this function had unpredictable behavior on non-existent paths. canonicalizePath :: (MonadIO m, MonadThrow m) - => path -> m (AbsPath path) + => path + -> m (AbsPath path) -- | Make a path absolute by prepending the current directory (if it isn't - -- already absolute) and applying 'normalise' to the result. + -- already absolute) and applying 'F.normalise' to the result. -- -- If the path is already absolute, the operation never fails. Otherwise, - -- the operation may fail with the same exceptions as - -- 'getCurrentDirectory'. + -- the operation may fail with the same exceptions as 'getCurrentDir'. makeAbsolute :: (MonadIO m, MonadThrow m) - => path -> m (AbsPath path) + => path + -> m (AbsPath path) - -- | Make a path relative to given directory. + -- | Make a path relative to a given directory. -- -- @since 0.3.0 @@ -817,27 +808,28 @@ -- @since 0.3.0 makeRelativeToCurrentDir :: (MonadIO m, MonadThrow m) - => path -> m (RelPath path) + => path + -> m (RelPath path) instance AnyPath (Path b File) where + + type AbsPath (Path b File) = Path Abs File + type RelPath (Path b File) = Path Rel File + 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 + + type AbsPath (Path b Dir) = Path Abs Dir + type RelPath (Path b Dir) = Path Rel Dir + 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. @@ -850,7 +842,6 @@ -> 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. -- @@ -860,7 +851,6 @@ => FilePath -- ^ Path to resolve -> m (Path Abs File) resolveFile' p = getCurrentDir >>= flip resolveFile p -{-# INLINE resolveFile' #-} -- | The same as 'resolveFile', but for directories. -- @@ -872,7 +862,6 @@ -> 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. -- @@ -882,7 +871,6 @@ => FilePath -- ^ Path to resolve -> m (Path Abs Dir) resolveDir' p = getCurrentDir >>= flip resolveDir p -{-# INLINE resolveDir' #-} ---------------------------------------------------------------------------- -- Actions on files @@ -920,7 +908,6 @@ 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 @@ -968,7 +955,6 @@ -> 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@ @@ -980,16 +966,15 @@ -> 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 -- executable or 'Nothing' if an executable with the given name was not -- found. For example ('findExecutable' \"ghc\") gives you the path to GHC. -- --- The path returned by 'findExecutable' corresponds to the --- program that would be executed by 'System.Process.createProcess' --- when passed the same string (as a RawCommand, not a ShellCommand). +-- The path returned by 'findExecutable' corresponds to the program that +-- would be executed by 'System.Process.createProcess' when passed the same +-- string (as a RawCommand, not a ShellCommand). -- -- On Windows, 'findExecutable' calls the Win32 function 'SearchPath', which -- may search other places before checking the directories in @PATH@. Where @@ -1001,7 +986,6 @@ => 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. @@ -1025,7 +1009,6 @@ -> 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 @@ -1046,6 +1029,20 @@ else findFilesWith f ds file ---------------------------------------------------------------------------- +-- Symbolic links + +-- | Check if the given path is a symbolic link. +-- +-- @since 1.3.0 + +isSymlink :: MonadIO m => Path b t -> m Bool +isSymlink p = liftIO $ liftM P.isSymbolicLink (P.getSymbolicLinkStatus path) + where + -- NOTE: To be able to correctly check whether it is a symlink or not we + -- have to drop the trailing separator from the dir path. + path = F.dropTrailingPathSeparator (toFilePath p) + +---------------------------------------------------------------------------- -- Temporary files and directories -- | Use a temporary file that doesn't already exist. @@ -1158,7 +1155,7 @@ (tfile, h) <- liftD2' T.openBinaryTempFile apath t (,h) `liftM` parseAbsFile tfile --- | Create temporary directory. The created directory isn't deleted +-- | Create a temporary directory. The created directory isn't deleted -- automatically, so you need to delete it manually. -- -- The directory is created with permissions such that only the current user @@ -1181,7 +1178,6 @@ 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' @@ -1189,7 +1185,6 @@ 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. @@ -1210,7 +1205,6 @@ forgivingAbsence f = catchIf isDoesNotExistError (Just `liftM` f) (const $ return Nothing) -{-# INLINE forgivingAbsence #-} -- | The same as 'forgivingAbsence', but ignores result. -- @@ -1218,7 +1212,6 @@ ignoringAbsence :: (MonadIO m, MonadCatch m) => m a -> m () ignoringAbsence = liftM (const ()) . forgivingAbsence -{-# INLINE ignoringAbsence #-} ---------------------------------------------------------------------------- -- Permissions @@ -1235,7 +1228,6 @@ 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. @@ -1249,7 +1241,6 @@ 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. @@ -1259,7 +1250,6 @@ -> Path b1 t1 -- ^ What to modify -> m () copyPermissions = liftD2 D.copyPermissions -{-# INLINE copyPermissions #-} ---------------------------------------------------------------------------- -- Timestamps @@ -1284,7 +1274,6 @@ 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. -- @@ -1313,7 +1302,6 @@ 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. -- @@ -1342,7 +1330,6 @@ setModificationTime :: MonadIO m => Path b t -> UTCTime -> m () setModificationTime = liftD2' D.setModificationTime -{-# INLINE setModificationTime #-} #endif -- | Obtain the time at which the file or directory was last modified. @@ -1360,7 +1347,6 @@ getModificationTime :: MonadIO m => Path b t -> m UTCTime getModificationTime = liftD D.getModificationTime -{-# INLINE getModificationTime #-} ---------------------------------------------------------------------------- -- Helpers @@ -1396,7 +1382,7 @@ liftD2' m a v = liftIO $ m (toFilePath a) v {-# INLINE liftD2' #-} --- | Perform specified action ignoring IO exceptions it may throw. +-- | Perform an action ignoring IO exceptions it may throw. ignoringIOErrors :: MonadCatch m => m () -> m () ignoringIOErrors ioe = ioe `catch` handler diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,13 +5,14 @@ [![Stackage Nightly](http://stackage.org/package/path-io/badge/nightly)](http://stackage.org/nightly/package/path-io) [![Stackage LTS](http://stackage.org/package/path-io/badge/lts)](http://stackage.org/lts/package/path-io) [![Build Status](https://travis-ci.org/mrkkrp/path-io.svg?branch=master)](https://travis-ci.org/mrkkrp/path-io) +[![Build status](https://ci.appveyor.com/api/projects/status/q0orxo6856n18jvg/branch/master?svg=true)](https://ci.appveyor.com/project/mrkkrp/path-io/branch/master) [![Coverage Status](https://coveralls.io/repos/mrkkrp/path-io/badge.svg?branch=master&service=github)](https://coveralls.io/github/mrkkrp/path-io?branch=master) -This package provides interface to -[`directory`](https://hackage.haskell.org/package/directory) package for +This package provides an interface to +the [`directory`](https://hackage.haskell.org/package/directory) package for users of Chris Done's [`path`](https://hackage.haskell.org/package/path). It also implements some missing stuff like recursive scanning and copying of -directories. +directories, working with temporary files/directories, etc. Consult Haddocks for usage, which should be trivial. diff --git a/path-io.cabal b/path-io.cabal --- a/path-io.cabal +++ b/path-io.cabal @@ -1,42 +1,11 @@ --- --- Cabal configuration for ‘path-io’. --- --- Copyright © 2016–2017 Mark Karpov --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- --- * Neither the name Mark Karpov nor the names of contributors may be used --- to endorse or promote products derived from this software without --- specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY --- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED --- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY --- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS --- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) --- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, --- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN --- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE --- POSSIBILITY OF SUCH DAMAGE. - name: path-io -version: 1.2.2 +version: 1.3.0 cabal-version: >= 1.10 +tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.1 license: BSD3 license-file: LICENSE.md -author: Mark Karpov -maintainer: Mark Karpov +author: Mark Karpov +maintainer: Mark Karpov homepage: https://github.com/mrkkrp/path-io bug-reports: https://github.com/mrkkrp/path-io/issues category: System, Filesystem @@ -59,7 +28,7 @@ , filepath >= 1.2 && < 1.5 , path >= 0.5 && < 0.6 , temporary >= 1.1 && < 1.3 - , time >= 1.4 && < 1.7 + , time >= 1.4 && < 1.9 , transformers >= 0.3 && < 0.6 , unix-compat exposed-modules: Path.IO @@ -81,7 +50,8 @@ , exceptions >= 0.8 && < 0.9 , hspec >= 2.0 && < 3.0 , path >= 0.5 && < 0.6 - , path-io >= 1.2.2 + , path-io + , transformers >= 0.3 && < 0.6 , unix-compat default-language: Haskell2010 diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,35 +1,3 @@ --- --- Tests for ‘path-io’ package. --- --- Copyright © 2016–2017 Mark Karpov --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- --- * Neither the name Mark Karpov nor the names of contributors may be used --- to endorse or promote products derived from this software without --- specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY --- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED --- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY --- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS --- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) --- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, --- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN --- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE --- POSSIBILITY OF SUCH DAMAGE. - {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} @@ -37,6 +5,7 @@ import Control.Monad import Control.Monad.Catch +import Control.Monad.IO.Class (MonadIO (..)) import Data.List (sort) import Path import Path.IO @@ -50,7 +19,10 @@ main :: IO () main = hspec . around withSandbox $ do +#ifndef mingw32_HOST_OS beforeWith populatedDir $ do + -- NOTE These tests shall fail on Windows as unix-compat does not + -- implement createSymbolicLink for windows. describe "listDir" listDirSpec describe "listDirRecur" listDirRecurSpec describe "listDirRecurWith" listDirRecurWithSpec @@ -58,15 +30,15 @@ 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 +#ifndef mingw32_HOST_OS + -- NOTE We can't quite test this on Windows as well, because the + -- environmental variables HOME and TMPDIR do not exist there. describe "getHomeDir" getHomeDirSpec describe "getTempDir" getTempDirSpec #if MIN_VERSION_directory(1,2,3) @@ -74,6 +46,7 @@ describe "getXdgDir Config" getXdgConfigDirSpec describe "getXdgDir Cache" getXdgCacheDirSpec #endif +#endif listDirSpec :: SpecWith (Path Abs Dir) listDirSpec = it "lists directory" $ \dir -> @@ -92,9 +65,9 @@ `shouldReturn` populatedDirRecurWith listDirRecurWith - :: (Path Abs Dir -> IO Bool) -- ^ Dir match predicate + :: (Path Abs Dir -> IO Bool) -- ^ Dir match predicate -> (Path Abs File -> IO Bool) -- ^ File match predicate - -> Path Abs Dir -- ^ Top dir to traverse + -> 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 @@ -102,10 +75,17 @@ f' <- filterM filePred f return (d', f') +-- Follows symbolic links +listDirRecurCyclic :: (MonadIO m, MonadThrow m) + => Path b Dir -- ^ Directory to list + -> m ([Path Abs Dir], [Path Abs File]) -- ^ Sub-directories and files +listDirRecurCyclic = walkDirAccum Nothing (\_ d f -> return (d, f)) + listDirRecurCyclicSpec :: SpecWith (Path Abs Dir) listDirRecurCyclicSpec = it "lists directory trees having traversal cycles" $ \dir -> - getDirStructure listDirRecur dir `shouldReturn` populatedCyclicDirStructure + getDirStructure listDirRecurCyclic 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 @@ -235,7 +215,7 @@ ---------------------------------------------------------------------------- -- Helpers --- | Create sandbox directory to model some situation in it and run some +-- | Create a sandbox directory to model some situation in it and run some -- tests. Note that we're using new unique sandbox directory for each test -- case to avoid contamination and it's unconditionally deleted after test -- case finishes. @@ -250,11 +230,15 @@ populatedDir :: Path Abs Dir -> IO (Path Abs Dir) populatedDir root = do - let (dirs, files) = populatedDirStructure + let (_, files) = populatedDirStructure pdir = root $(mkRelDir "pdir") withinSandbox = (pdir ) ensureDir pdir - forM_ dirs (ensureDir . withinSandbox) + ensureDir $ withinSandbox $(mkRelDir "b") + ensureDir $ withinSandbox $(mkRelDir "b/c") + -- to verify that we do not follow symbolic links. We should not list b's + -- tree under 'a'. + createSymbolicLink "b" (toFilePath $ withinSandbox $(mkRelFile "a")) forM_ files $ (`writeFile` "") . toFilePath . withinSandbox return pdir @@ -291,12 +275,12 @@ -- | 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 +-- 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) +-- a\/(b -> c), c\/(d -> a) +-- c\/(d -> a), a\/(b -> c) -- 2) Cycle with own ancestor - -- e/f/(g -> e) +-- e\/f\/(g -> e) populatedCyclicDirStructure :: ([Path Rel Dir], [Path Rel File]) populatedCyclicDirStructure = @@ -351,7 +335,8 @@ ( [ $(mkRelDir "a") , $(mkRelDir "b") ] - , [ $(mkRelFile "b/c/three.txt") + , [ $(mkRelFile "a/c/three.txt") -- via symbolic link + , $(mkRelFile "b/c/three.txt") , $(mkRelFile "one.txt") ] )