Hello community,
here is the log from the commit of package ghc-path-io for openSUSE:Factory
checked in at 2016-10-23 12:50:55
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-path-io (Old)
and /work/SRC/openSUSE:Factory/.ghc-path-io.new (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-path-io"
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-path-io/ghc-path-io.changes 2016-07-20
09:29:24.000000000 +0200
+++ /work/SRC/openSUSE:Factory/.ghc-path-io.new/ghc-path-io.changes
2016-10-23 12:50:56.000000000 +0200
@@ -1,0 +2,5 @@
+Thu Sep 15 06:37:17 UTC 2016 - psim...@suse.com
+
+- Update to version 1.2.0 revision 0 with cabal2obs.
+
+-------------------------------------------------------------------
Old:
----
path-io-1.1.0.tar.gz
New:
----
path-io-1.2.0.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-path-io.spec ++++++
--- /var/tmp/diff_new_pack.Ld5Z5j/_old 2016-10-23 12:50:57.000000000 +0200
+++ /var/tmp/diff_new_pack.Ld5Z5j/_new 2016-10-23 12:50:57.000000000 +0200
@@ -19,15 +19,15 @@
%global pkg_name path-io
%bcond_with tests
Name: ghc-%{pkg_name}
-Version: 1.1.0
+Version: 1.2.0
Release: 0
Summary: Interface to ‘directory’ package for users of ‘path’
License: BSD-3-Clause
-Group: System/Libraries
+Group: Development/Languages/Other
Url: https://hackage.haskell.org/package/%{pkg_name}
Source0:
https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz
BuildRequires: ghc-Cabal-devel
-# Begin cabal-rpm deps:
+BuildRequires: ghc-containers-devel
BuildRequires: ghc-directory-devel
BuildRequires: ghc-exceptions-devel
BuildRequires: ghc-filepath-devel
@@ -36,11 +36,11 @@
BuildRequires: ghc-temporary-devel
BuildRequires: ghc-time-devel
BuildRequires: ghc-transformers-devel
+BuildRequires: ghc-unix-compat-devel
BuildRoot: %{_tmppath}/%{name}-%{version}-build
%if %{with tests}
BuildRequires: ghc-hspec-devel
%endif
-# End cabal-rpm deps
%description
Interface to ‘directory’ package for users of ‘path’.
@@ -59,20 +59,14 @@
%prep
%setup -q -n %{pkg_name}-%{version}
-
%build
%ghc_lib_build
-
%install
%ghc_lib_install
-
%check
-%if %{with tests}
-%{cabal} test
-%endif
-
+%cabal_test
%post devel
%ghc_pkg_recache
++++++ path-io-1.1.0.tar.gz -> path-io-1.2.0.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/path-io-1.1.0/CHANGELOG.md
new/path-io-1.2.0/CHANGELOG.md
--- old/path-io-1.1.0/CHANGELOG.md 2016-03-05 08:51:10.000000000 +0100
+++ new/path-io-1.2.0/CHANGELOG.md 2016-07-18 09:53:36.000000000 +0200
@@ -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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/path-io-1.1.0/Path/IO.hs new/path-io-1.2.0/Path/IO.hs
--- old/path-io-1.1.0/Path/IO.hs 2016-03-05 09:24:42.000000000 +0100
+++ new/path-io-1.2.0/Path/IO.hs 2016-07-18 09:52:24.000000000 +0200
@@ -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.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/path-io-1.1.0/path-io.cabal
new/path-io-1.2.0/path-io.cabal
--- old/path-io-1.1.0/path-io.cabal 2016-03-05 09:32:51.000000000 +0100
+++ new/path-io-1.2.0/path-io.cabal 2016-07-18 09:38:38.000000000 +0200
@@ -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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/path-io-1.1.0/tests/Main.hs
new/path-io-1.2.0/tests/Main.hs
--- old/path-io-1.1.0/tests/Main.hs 2016-03-05 09:28:30.000000000 +0100
+++ new/path-io-1.2.0/tests/Main.hs 2016-07-18 09:20:51.000000000 +0200
@@ -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.
@@ -210,3 +301,17 @@
, [ $(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")
+ ]
+ )
