[commit: packages/directory] improve-tests, improve-tests-for-real, master: Make behavior of `removeDirectoryRecursive` more consistent (ca34a87)
git at git.haskell.org
git at git.haskell.org
Thu Mar 19 11:37:28 UTC 2015
Repository : ssh://git@git.haskell.org/directory
On branches: improve-tests,improve-tests-for-real,master
Link : http://ghc.haskell.org/trac/ghc/changeset/ca34a8774fd19131d594972934940267483b27ab/directory
>---------------------------------------------------------------
commit ca34a8774fd19131d594972934940267483b27ab
Author: Phil Ruffwind <rf at rufflewind.com>
Date: Sat Jan 31 18:41:34 2015 -0500
Make behavior of `removeDirectoryRecursive` more consistent
The way `removeDirectoryRecursive dir` works right now is totally
inconsistent:
- If there's a directory-like symbolic link, the function removes it
without recursing into it, *unless* the symbolic link is not
removable for some reason (e.g. no permission), in which case it
recurses into it and wipes out everything inside.
- If `dir` itself is actually a directory-like symbolic link, it will
recurse into it but fail to remove `dir` itself.
The causes of these two problems are:
- Instead of explicitly checking whether path refers to a true
directory, it assumes any unremovable file that also satisfies
`directoryExists` must necessarily be a directory. This is false,
because `directoryExists` dereferences the symbolic link.
- `getDirectoryContents` should not be called until `dir` is verified
to be a true directory.
There are two possible ways to handle the case where `dir` is not a true
directory:
- One can delete it silently, similar to the behavior of the POSIX
command `rm -r`.
- Or one can raise an error, similar to the behavior of the Python
function `shutil.rmtree`.
The former is more elegant to implement but for backward compatibility
`removeDirectoryRecursive` shall retain the Python-like behavior.
Another function `removePathRecursive` was added to implement the POSIX
behavior, although the decision of to export this function will be left
for the future.
On Windows, there are two kinds of symbolic links:
- directory symbolic links, and
- file symbolic links.
Directory symbolic links are treated as directories on Windows, which
means `lstat` considers them directories and `DeleteFile` doesn't work.
To remedy this, `removePathRecursive` was tweaked to handle these
unusual cases and avoid following symbolic links.
>---------------------------------------------------------------
ca34a8774fd19131d594972934940267483b27ab
System/Directory.hs | 104 ++++++++++++++++++++++++++++++++--------------------
changelog.md | 4 +-
2 files changed, 68 insertions(+), 40 deletions(-)
diff --git a/System/Directory.hs b/System/Directory.hs
index beb30c8..6ed772e 100644
--- a/System/Directory.hs
+++ b/System/Directory.hs
@@ -406,6 +406,33 @@ createDirectoryIfMissing create_parents path0
| otherwise -> throwIO e
#if __GLASGOW_HASKELL__
+
+-- | * @'NotDirectory'@: not a directory.
+-- * @'Directory'@: a true directory (not a symbolic link).
+-- * @'DirectoryLink'@: a directory symbolic link (only exists on Windows).
+data DirectoryType = NotDirectory
+ | Directory
+ | DirectoryLink
+ deriving (Enum, Eq, Ord, Read, Show)
+
+-- | Obtain the type of a directory.
+getDirectoryType :: FilePath -> IO DirectoryType
+getDirectoryType path =
+ (`ioeSetLocation` "getDirectoryType") `modifyIOError` do
+#ifdef mingw32_HOST_OS
+ fmap classify (Win32.getFileAttributes path)
+ where fILE_ATTRIBUTE_REPARSE_POINT = 0x400
+ classify attr
+ | attr .&. Win32.fILE_ATTRIBUTE_DIRECTORY == 0 = NotDirectory
+ | attr .&. fILE_ATTRIBUTE_REPARSE_POINT == 0 = Directory
+ | otherwise = DirectoryLink
+#else
+ stat <- Posix.getSymbolicLinkStatus path
+ return $ if Posix.isDirectory stat
+ then Directory
+ else NotDirectory
+#endif
+
{- | @'removeDirectory' 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
@@ -457,24 +484,39 @@ removeDirectory path =
#endif
--- | @'removeDirectoryRecursive' dir@ removes an existing directory /dir/
--- together with its content and all subdirectories. Be careful, if the
--- directory contains symlinks, this function will follow them if you don't
--- have permission to delete them.
+-- | @'removeDirectoryRecursive' dir@ removes an existing directory /dir/
+-- together with its contents and subdirectories. Symbolic links are removed
+-- without affecting their the targets.
removeDirectoryRecursive :: FilePath -> IO ()
-removeDirectoryRecursive startLoc = do
- cont <- getDirectoryContents startLoc
- sequence_ [rm (startLoc </> x) | x <- cont, x /= "." && x /= ".."]
- removeDirectory startLoc
- where
- rm :: FilePath -> IO ()
- rm f = do temp <- E.try (removeFile f)
- case temp of
- Left e -> do isDir <- doesDirectoryExist f
- -- If f is not a directory, re-throw the error
- unless isDir $ throwIO (e :: SomeException)
- removeDirectoryRecursive f
- Right _ -> return ()
+removeDirectoryRecursive path =
+ (`ioeSetLocation` "removeDirectoryRecursive") `modifyIOError` do
+ dirType <- getDirectoryType path
+ case dirType of
+ Directory -> removeContentsRecursive path
+ _ -> ioError . (`ioeSetErrorString` "not a directory") $
+ mkIOError InappropriateType "" Nothing (Just path)
+
+-- | @'removePathRecursive' path@ removes an existing file or directory at
+-- /path/ together with its contents and subdirectories. Symbolic links are
+-- removed without affecting their the targets.
+removePathRecursive :: FilePath -> IO ()
+removePathRecursive path =
+ (`ioeSetLocation` "removePathRecursive") `modifyIOError` do
+ dirType <- getDirectoryType path
+ case dirType of
+ NotDirectory -> removeFile path
+ Directory -> removeContentsRecursive path
+ DirectoryLink -> removeDirectory path
+
+-- | @'removeContentsRecursive' dir@ removes the contents of the directory
+-- /dir/ recursively. Symbolic links are removed without affecting their the
+-- targets.
+removeContentsRecursive :: FilePath -> IO ()
+removeContentsRecursive path =
+ (`ioeSetLocation` "removeContentsRecursive") `modifyIOError` do
+ cont <- getDirectoryContents path
+ mapM_ removePathRecursive [path </> x | x <- cont, x /= "." && x /= ".."]
+ removeDirectory path
#if __GLASGOW_HASKELL__
{- |'removeFile' /file/ removes the directory entry for an existing file
@@ -635,21 +677,13 @@ Either path refers to an existing directory.
-}
renameFile :: FilePath -> FilePath -> IO ()
-renameFile opath npath = do
+renameFile opath npath = (`ioeSetLocation` "renameFile") `modifyIOError` do
-- XXX this test isn't performed atomically with the following rename
-#ifdef mingw32_HOST_OS
- -- ToDo: use Win32 API
- withFileOrSymlinkStatus "renameFile" opath $ \st -> do
- is_dir <- isDirectory st
-#else
- stat <- Posix.getSymbolicLinkStatus opath
- let is_dir = Posix.isDirectory stat
-#endif
- if is_dir
- then ioError (ioeSetErrorString
- (mkIOError InappropriateType "renameFile" Nothing (Just opath))
- "is a directory")
- else do
+ dirType <- getDirectoryType opath
+ case dirType of
+ Directory -> ioError . (`ioeSetErrorString` "is a directory") $
+ mkIOError InappropriateType "" Nothing (Just opath)
+ _ -> return ()
#ifdef mingw32_HOST_OS
Win32.moveFileEx opath npath Win32.mOVEFILE_REPLACE_EXISTING
#else
@@ -1038,14 +1072,6 @@ withFileStatus loc name f = do
throwErrnoIfMinus1Retry_ loc (c_stat s p)
f p
-withFileOrSymlinkStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a
-withFileOrSymlinkStatus loc name f = do
- modifyIOError (`ioeSetFileName` name) $
- allocaBytes sizeof_stat $ \p ->
- withFilePath name $ \s -> do
- throwErrnoIfMinus1Retry_ loc (lstat s p)
- f p
-
isDirectory :: Ptr CStat -> IO Bool
isDirectory stat = do
mode <- st_mode stat
diff --git a/changelog.md b/changelog.md
index 79b8841..bc2d62a 100644
--- a/changelog.md
+++ b/changelog.md
@@ -14,7 +14,9 @@
* Expose `findExecutables` [#14](https://github.com/haskell/directory/issues/14)
- * Clarify conditions under which `removeDirectoryRecursive` may follow a symlink
+ * `removeDirectoryRecursive` no longer follows symlinks under any
+ circumstances, fixing the inconsistency as noted in
+ [#15](https://github.com/haskell/directory/issues/15)
## 1.2.1.0 *Mar 2014*
More information about the ghc-commits
mailing list