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") + ] + )