[commit: packages/directory] Mistuke-bump-win32-version-bounds, bgamari-patch-1, master: Improve robustness of removePathForcibly (1a5edff)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/directory

On branches: Mistuke-bump-win32-version-bounds,bgamari-patch-1,master
Link       : http://ghc.haskell.org/trac/ghc/changeset/1a5edff2b6fc1620bab7ec3ebe9c0aa49a76fbc8/directory

>---------------------------------------------------------------

commit 1a5edff2b6fc1620bab7ec3ebe9c0aa49a76fbc8
Author: Phil Ruffwind <rf at rufflewind.com>
Date:   Wed Oct 19 05:13:22 2016 -0400

    Improve robustness of removePathForcibly
    
    Fixes #60.


>---------------------------------------------------------------

1a5edff2b6fc1620bab7ec3ebe9c0aa49a76fbc8
 System/Directory.hs | 55 ++++++++++++++++++++++++++++++++++++++++++-----------
 changelog.md        |  6 ++++++
 directory.cabal     |  2 +-
 3 files changed, 51 insertions(+), 12 deletions(-)

diff --git a/System/Directory.hs b/System/Directory.hs
index 9cc9d03..3ab645e 100644
--- a/System/Directory.hs
+++ b/System/Directory.hs
@@ -570,35 +570,68 @@ removeContentsRecursive path =
     mapM_ removePathRecursive [path </> x | x <- cont]
     removeDirectory path
 
--- | @'removePathForcibly@ removes a file or directory at /path/ together with
--- its contents and subdirectories. Symbolic links are removed without
--- affecting their the targets. If the path does not exist, nothing happens.
+-- | Removes a file or directory at /path/ together with its contents and
+-- subdirectories. Symbolic links are removed without affecting their
+-- targets. If the path does not exist, nothing happens.
 --
 -- Unlike other removal functions, this function will also attempt to delete
 -- files marked as read-only or otherwise made unremovable due to permissions.
 -- As a result, if the removal is incomplete, the permissions or attributes on
 -- the remaining files may be altered.
 --
+-- If an entry within the directory vanishes while @removePathForcibly@ is
+-- running, it is silently ignored.
+--
+-- If an exception occurs while removing an entry, @removePathForcibly@ will
+-- still try to remove as many entries as it can before failing with an
+-- exception.  The first exception that it encountered is re-thrown.
+--
 -- @since 1.2.7.0
 removePathForcibly :: FilePath -> IO ()
 removePathForcibly path =
   (`ioeSetLocation` "removePathForcibly") `modifyIOError` do
     makeRemovable path `catchIOError` \ _ -> return ()
-    dirType <- tryIOErrorType isDoesNotExistError (getDirectoryType path)
-    case dirType of
-      Left _              -> return ()
-      Right NotDirectory  -> removeFile path
-      Right DirectoryLink -> removeDirectory path
-      Right Directory     -> do
-        mapM_ (removePathForcibly . (path </>)) =<< listDirectory path
-        removeDirectory path
+    ignoreDoesNotExistError $ do
+      dirType <- getDirectoryType path
+      case dirType of
+        NotDirectory  -> removeFile path
+        DirectoryLink -> removeDirectory path
+        Directory     -> do
+          names <- listDirectory path
+          sequenceWithIOErrors_ $
+            [ removePathForcibly (path </> name) | name <- names ] ++
+            [ removeDirectory path ]
   where
+
+    ignoreDoesNotExistError :: IO () -> IO ()
+    ignoreDoesNotExistError action = do
+      _ <- tryIOErrorType isDoesNotExistError action
+      return ()
+
+    makeRemovable :: FilePath -> IO ()
     makeRemovable p = do
       perms <- getPermissions p
       setPermissions path perms{ readable = True
                                , searchable = True
                                , writable = True }
 
+sequenceWithIOErrors_ :: [IO ()] -> IO ()
+sequenceWithIOErrors_ actions = go (Right ()) actions
+  where
+
+    go :: Either IOError () -> [IO ()] -> IO ()
+    go (Left e)   []       = ioError e
+    go (Right ()) []       = return ()
+    go s          (m : ms) = s `seq` do
+      r <- tryIOError m
+      go (thenEither s r) ms
+
+    -- equivalent to (*>) for Either, defined here to retain compatibility
+    -- with base prior to 4.3
+    thenEither :: Either b a -> Either b a -> Either b a
+    thenEither x@(Left _) _ = x
+    thenEither _          y = y
+
 {- |'removeFile' /file/ removes the directory entry for an existing file
 /file/, where /file/ is not itself a directory. The
 implementation may specify additional constraints which must be
diff --git a/changelog.md b/changelog.md
index ea31890..a0bf189 100644
--- a/changelog.md
+++ b/changelog.md
@@ -1,6 +1,12 @@
 Changelog for the [`directory`][1] package
 ==========================================
 
+## 1.2.7.1 (November 2016)
+
+  * Don't abort `removePathForcibly` if files or directories go missing.
+    In addition, keep going even if an exception occurs.
+    ([#60](https://github.com/haskell/directory/issues/60))
+
 ## 1.2.7.0 (August 2016)
 
   * Remove deprecated C bits.  This means `HsDirectory.h` and its functions
diff --git a/directory.cabal b/directory.cabal
index e9e6108..248e840 100644
--- a/directory.cabal
+++ b/directory.cabal
@@ -1,5 +1,5 @@
 name:           directory
-version:        1.2.7.0
+version:        1.2.7.1
 -- NOTE: Don't forget to update ./changelog.md
 license:        BSD3
 license-file:   LICENSE