[commit: packages/directory] master: Update test runner to fix permissions before clearing the directory (60fcdd2)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/60fcdd2a26e2dbd603d515ae81d0d7d51db7a6be/directory

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

commit 60fcdd2a26e2dbd603d515ae81d0d7d51db7a6be
Author: Phil Ruffwind <rf at rufflewind.com>
Date:   Thu Apr 14 05:34:15 2016 -0400

    Update test runner to fix permissions before clearing the directory
    
    Otherwise, tests that alter the permission of files could break the test
    runner.  For example, this can happen if RemoveDirectoryRecursive001 is
    interrupted at an unfortunate moment.


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

60fcdd2a26e2dbd603d515ae81d0d7d51db7a6be
 System/Directory.hs |  2 +-
 tests/Util.hs       | 33 +++++++++++++++++++++++++++++----
 2 files changed, 30 insertions(+), 5 deletions(-)

diff --git a/System/Directory.hs b/System/Directory.hs
index ef97bcd..44012d6 100644
--- a/System/Directory.hs
+++ b/System/Directory.hs
@@ -490,7 +490,7 @@ getDirectoryType :: FilePath -> IO DirectoryType
 getDirectoryType path =
   (`ioeSetLocation` "getDirectoryType") `modifyIOError` do
 #ifdef mingw32_HOST_OS
-    isDir <- withFileStatus "getDirectoryType" name isDirectory
+    isDir <- withFileStatus "getDirectoryType" path isDirectory
     if isDir
       then do
         isLink <- isSymbolicLink path
diff --git a/tests/Util.hs b/tests/Util.hs
index ca4a448..12a0f42 100644
--- a/tests/Util.hs
+++ b/tests/Util.hs
@@ -2,8 +2,9 @@
 module Util where
 import Prelude (Eq(..), Num(..), Ord(..), RealFrac(..), Show(..),
                 Bool(..), Double, Either(..), Int, Integer, Maybe(..), String,
-                ($), (.), otherwise)
+                ($), (.), not, otherwise)
 import Data.Char (toLower)
+import Data.Foldable (traverse_)
 import Data.Functor ((<$>))
 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
 import Data.List (drop, elem, intercalate, lookup, reverse, span)
@@ -16,11 +17,14 @@ import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar)
 import Control.Exception (SomeException, bracket_, catch,
                           mask, onException, try)
 import Control.Monad (Monad(..), unless, when)
-import System.Directory (createDirectoryIfMissing, makeAbsolute,
-                         removeDirectoryRecursive, withCurrentDirectory)
+import System.Directory (createDirectoryIfMissing, emptyPermissions,
+                         doesDirectoryExist, isSymbolicLink, listDirectory,
+                         makeAbsolute, removeDirectoryRecursive, readable,
+                         searchable, setPermissions, withCurrentDirectory,
+                         writable)
 import System.Environment (getArgs)
 import System.Exit (exitFailure)
-import System.FilePath (FilePath, normalise)
+import System.FilePath (FilePath, (</>), normalise)
 import System.IO (IO, hFlush, hPutStrLn, putStrLn, stderr, stdout)
 import System.IO.Error (IOError, isDoesNotExistError,
                         ioError, tryIOError, userError)
@@ -131,6 +135,20 @@ expectIOErrorType t file line context which action = do
             | otherwise -> Left  ["got wrong exception: ", show e]
     Right _             -> Left  ["did not throw an exception"]
 
+-- | Traverse the directory tree in preorder.
+preprocessPathRecursive :: (FilePath -> IO ()) -> FilePath -> IO ()
+preprocessPathRecursive f path = do
+  dirExists <- doesDirectoryExist path
+  if dirExists
+    then do
+      isLink <- isSymbolicLink path
+      f path
+      when (not isLink) $ do
+        names <- listDirectory path
+        traverse_ (preprocessPathRecursive f) ((path </>) <$> names)
+    else do
+      f path
+
 withNewDirectory :: Bool -> FilePath -> IO a -> IO a
 withNewDirectory keep dir action = do
   dir' <- makeAbsolute dir
@@ -144,6 +162,13 @@ isolateWorkingDirectory keep dir action = do
     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