From a3e0a453aeb3871664a68bcc5982405cb7c9f364 Mon Sep 17 00:00:00 2001
From: Phil Ruffwind <rf@rufflewind.com>
Date: Sat, 31 Jan 2015 18:41:34 -0500
Subject: [PATCH] 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.

Note that 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 it is currently not exported.
---
 System/Directory.hs | 69 +++++++++++++++++++++++++++++----------------
 1 file changed, 44 insertions(+), 25 deletions(-)

diff --git a/System/Directory.hs b/System/Directory.hs
index 26600a06..7bdbc50a 100644
--- a/System/Directory.hs
+++ b/System/Directory.hs
@@ -456,24 +456,49 @@ removeDirectory path =
 
 #endif
 
--- | @'removeDirectoryRecursive' dir@ removes an existing directory
--- /dir/ together with its content and all subdirectories. If the
--- directory contains symlinks this function removes but does not
--- follow 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
+    isDir <- isRealDirectory path
+    if isDir
+      then removeContentsRecursive path
+      else 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
+    isDir <- isRealDirectory path
+    if isDir
+      then removeContentsRecursive path
+      else removeFile 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
+
+-- | @'isRealDirectory path'@ checks whether /path/ refers to an actual
+-- directory, i.e. not a symbolic link to another directory.
+isRealDirectory :: FilePath -> IO Bool
+isRealDirectory path =
+#ifdef mingw32_HOST_OS
+  -- ToDo: use Win32 API
+  withFileOrSymlinkStatus "" path isDirectory
+#else
+  Posix.isDirectory `fmap` Posix.getSymbolicLinkStatus path
+#endif
 
 #if __GLASGOW_HASKELL__
 {- |'removeFile' /file/ removes the directory entry for an existing file
@@ -636,14 +661,8 @@ Either path refers to an existing directory.
 renameFile :: FilePath -> FilePath -> IO ()
 renameFile opath npath = 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
+   is_dir <- (`ioeSetLocation` "renameFile") `modifyIOError`
+             isRealDirectory opath
    if is_dir
         then ioError (ioeSetErrorString
                           (mkIOError InappropriateType "renameFile" Nothing (Just opath))