Add removePathForcibly

Fixes haskell#59.

System/Directory.hs

@@ -29,6 +29,7 @@ module System.Directory
     , createDirectoryIfMissing
     , removeDirectory
     , removeDirectoryRecursive
+    , removePathForcibly
     , renameDirectory
     , listDirectory
     , getDirectoryContents
@@ -569,6 +570,33 @@ 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.
+--
+-- 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.
+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
+  where
+    makeRemovable p = do
+      perms <- getPermissions p
+      setPermissions path perms{ readable = True
+                               , searchable = True
+                               , writable = True }
+
 {- |'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

changelog.md

@@ -1,7 +1,7 @@
 Changelog for the [`directory`][1] package
 ==========================================
 
-## 1.2.7.0 (June 2016)
+## 1.2.7.0 (August 2016)
 
   * Remove deprecated C bits.  This means `HsDirectory.h` and its functions
     are no longer available.
@@ -13,6 +13,9 @@ Changelog for the [`directory`][1] package
   * Add `renamePath`
     ([#58](https://github.com/haskell/directory/issues/58))
 
+  * Add `removePathForcibly`
+    ([#59](https://github.com/haskell/directory/issues/59))
+
 ## 1.2.6.3 (May 2016)
 
   * Add missing import of `(<*>)` on Windows for `base` earlier than 4.8.0.0

directory.cabal

@@ -97,6 +97,7 @@ test-suite test
         GetPermissions001
         IsSymbolicLink
         RemoveDirectoryRecursive001
+        RemovePathForcibly
         RenameDirectory
         RenameFile001
         RenamePath

tests/Main.hs

@@ -19,6 +19,7 @@ import qualified GetHomeDirectory001
 import qualified GetPermissions001
 import qualified IsSymbolicLink
 import qualified RemoveDirectoryRecursive001
+import qualified RemovePathForcibly
 import qualified RenameDirectory
 import qualified RenameFile001
 import qualified RenamePath
@@ -47,6 +48,7 @@ main = T.testMain $ \ _t -> do
   T.isolatedRun _t "GetPermissions001" GetPermissions001.main
   T.isolatedRun _t "IsSymbolicLink" IsSymbolicLink.main
   T.isolatedRun _t "RemoveDirectoryRecursive001" RemoveDirectoryRecursive001.main
+  T.isolatedRun _t "RemovePathForcibly" RemovePathForcibly.main
   T.isolatedRun _t "RenameDirectory" RenameDirectory.main
   T.isolatedRun _t "RenameFile001" RenameFile001.main
   T.isolatedRun _t "RenamePath" RenamePath.main

tests/RemovePathForcibly.hs

@@ -0,0 +1,91 @@
+{-# LANGUAGE CPP #-}
+module RemovePathForcibly where
+#include "util.inl"
+import System.Directory
+import Data.List (sort)
+import System.FilePath ((</>), normalise)
+import System.IO.Error (catchIOError)
+import TestUtils
+
+main :: TestEnv -> IO ()
+main _t = do
+
+  ------------------------------------------------------------
+  -- clean up junk from previous invocations
+
+  modifyPermissions (tmp "c") (\ p -> p { writable = True })
+    `catchIOError` \ _ -> return ()
+  removePathForcibly tmpD
+    `catchIOError` \ _ -> return ()
+
+  ------------------------------------------------------------
+  -- set up
+
+  createDirectoryIfMissing True (tmp "a/x/w")
+  createDirectoryIfMissing True (tmp "a/y")
+  createDirectoryIfMissing True (tmp "a/z")
+  createDirectoryIfMissing True (tmp "b")
+  createDirectoryIfMissing True (tmp "c")
+  createDirectoryIfMissing True (tmp "f")
+  writeFile (tmp "a/x/w/u") "foo"
+  writeFile (tmp "a/t")     "bar"
+  writeFile (tmp "f/s")     "qux"
+  tryCreateSymbolicLink (normalise "../a") (tmp "b/g")
+  tryCreateSymbolicLink (normalise "../b") (tmp "c/h")
+  tryCreateSymbolicLink (normalise "a")    (tmp "d")
+  tryCreateSymbolicLink (normalise "f")    (tmp "e")
+  setPermissions (tmp "f/s") emptyPermissions
+  setPermissions (tmp "f") emptyPermissions
+
+  ------------------------------------------------------------
+  -- tests
+
+  removePathForcibly (tmp "f")
+  removePathForcibly (tmp "e")
+
+  T(expectEq) () [".", "..", "a", "b", "c", "d"] . sort =<<
+    getDirectoryContents  tmpD
+  T(expectEq) () [".", "..", "t", "x", "y", "z"] . sort =<<
+    getDirectoryContents (tmp "a")
+  T(expectEq) () [".", "..", "g"] . sort =<<
+    getDirectoryContents (tmp "b")
+  T(expectEq) () [".", "..", "h"] . sort =<<
+    getDirectoryContents (tmp "c")
+  T(expectEq) () [".", "..", "t", "x", "y", "z"] . sort =<<
+    getDirectoryContents (tmp "d")
+
+  removePathForcibly (tmp "d")
+
+  T(expectEq) () [".", "..", "a", "b", "c"] . sort =<<
+    getDirectoryContents  tmpD
+  T(expectEq) () [".", "..", "t", "x", "y", "z"] . sort =<<
+    getDirectoryContents (tmp "a")
+  T(expectEq) () [".", "..", "g"] . sort =<<
+    getDirectoryContents (tmp "b")
+  T(expectEq) () [".", "..", "h"] . sort =<<
+    getDirectoryContents (tmp "c")
+
+  removePathForcibly (tmp "c")
+
+  T(expectEq) () [".", "..", "a", "b"] . sort =<<
+    getDirectoryContents  tmpD
+  T(expectEq) () [".", "..", "t", "x", "y", "z"] . sort =<<
+   getDirectoryContents (tmp "a")
+  T(expectEq) () [".", "..", "g"] . sort =<<
+    getDirectoryContents (tmp "b")
+
+  removePathForcibly (tmp "b")
+
+  T(expectEq) () [".", "..", "a"] . sort =<<
+    getDirectoryContents  tmpD
+  T(expectEq) () [".", "..", "t", "x", "y", "z"] . sort =<<
+    getDirectoryContents (tmp "a")
+
+  removePathForcibly (tmp "a")
+
+  T(expectEq) () [".", ".."] . sort =<<
+    getDirectoryContents  tmpD
+
+  where testName = "removePathForcibly"
+        tmpD  = testName ++ ".tmp"
+        tmp s = tmpD </> normalise s

tests/Util.hs

@@ -14,20 +14,16 @@ import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime)
 import Control.Arrow (second)
 import Control.Concurrent (forkIO, killThread)
 import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar)
-import Control.Exception (SomeException, bracket_, catch,
-                          mask, onException, try)
+import Control.Exception (SomeException, bracket_, mask, onException, try)
 import Control.Monad (Monad(..), unless, when)
-import System.Directory (createDirectoryIfMissing, emptyPermissions,
-                         doesDirectoryExist, isSymbolicLink, listDirectory,
-                         makeAbsolute, removeDirectoryRecursive, readable,
-                         searchable, setPermissions, withCurrentDirectory,
-                         writable)
+import System.Directory (createDirectoryIfMissing, doesDirectoryExist,
+                         isSymbolicLink, listDirectory, makeAbsolute,
+                         removePathForcibly, withCurrentDirectory)
 import System.Environment (getArgs)
 import System.Exit (exitFailure)
 import System.FilePath (FilePath, (</>), normalise)
 import System.IO (IO, hFlush, hPutStrLn, putStrLn, stderr, stdout)
-import System.IO.Error (IOError, isDoesNotExistError,
-                        ioError, tryIOError, userError)
+import System.IO.Error (IOError, ioError, tryIOError, userError)
 import System.Timeout (timeout)
 import Text.Read (Read, reads)
 
@@ -154,24 +150,15 @@ withNewDirectory keep dir action = do
   dir' <- makeAbsolute dir
   bracket_ (createDirectoryIfMissing True dir') (cleanup dir') action
   where cleanup dir' | keep      = return ()
-                     | otherwise = removeDirectoryRecursive dir'
+                     | otherwise = removePathForcibly dir'
 
 isolateWorkingDirectory :: Bool -> FilePath -> IO a -> IO a
 isolateWorkingDirectory keep dir action = do
   when (normalise dir `elem` [".", "./"]) $
     ioError (userError ("isolateWorkingDirectory cannot be used " <>
                         "with current directory"))
   dir' <- makeAbsolute dir
-  (`preprocessPathRecursive` dir') $ \ f -> do
-    setPermissions f emptyPermissions{ readable = True
-                                     , searchable = True
-                                     , writable = True }
-      `catch` \ e ->
-        unless (isDoesNotExistError e) $
-          ioError e
-  removeDirectoryRecursive dir' `catch` \ e ->
-    unless (isDoesNotExistError e) $
-      ioError e
+  removePathForcibly dir'
   withNewDirectory keep dir' $
     withCurrentDirectory dir' $
       action