[commit: packages/directory] improve-tests, improve-tests-for-real, master, tmp: Fix `createDirectoryIfMissing` silently failing (1f11393)

[git at git.haskell.org]

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

On branches: improve-tests,improve-tests-for-real,master,tmp
Link       : http://ghc.haskell.org/trac/ghc/changeset/1f113935439a381443b945eb5177fb122881f182/directory

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

commit 1f113935439a381443b945eb5177fb122881f182
Author: Herbert Valerio Riedel <hvr at gnu.org>
Date:   Mon Jan 19 14:18:09 2015 +0100

    Fix `createDirectoryIfMissing` silently failing
    
    In some cases, `createDirectoryIfMissing` would silently fail. For
    example the following invocation would fail to report via an exception
    that it couldn't create a folder:
    
      let testdir = "/tmp/sometestdir"
      writeFile testdir ""
      createDirectoryIfMissing False testdir
    
    A related issue was the failure to create a folder hierarchy due to lack
    of permissions, for instance
    
      createDirectoryIfMissing True "/foo"
    
    for a non-priviledged user would silently fail (i.e. no exception
    thrown), even though "/foo" was not created.
    
    Fixes #4 (see also #10 for discussion)


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

1f113935439a381443b945eb5177fb122881f182
 System/Directory.hs                      | 16 ++++++----------
 tests/createDirectoryIfMissing001.hs     | 12 ++++++++++++
 tests/createDirectoryIfMissing001.stdout |  2 ++
 3 files changed, 20 insertions(+), 10 deletions(-)

diff --git a/System/Directory.hs b/System/Directory.hs
index 98e4c20..26600a0 100644
--- a/System/Directory.hs
+++ b/System/Directory.hs
@@ -393,19 +393,15 @@ createDirectoryIfMissing create_parents path0
           -- This caused GHCi to crash when loading a module in the root
           -- directory.
           | isAlreadyExistsError e
-         || isPermissionError e -> (do
+         || isPermissionError e -> do
 #ifdef mingw32_HOST_OS
-              withFileStatus "createDirectoryIfMissing" dir $ \st -> do
-                 isDir <- isDirectory st
-                 if isDir then return ()
-                          else throwIO e
+              canIgnore <- (withFileStatus "createDirectoryIfMissing" dir isDirectory)
 #else
-              stat <- Posix.getFileStatus dir
-              if Posix.isDirectory stat
-                 then return ()
-                 else throwIO e
+              canIgnore <- (Posix.isDirectory `fmap` Posix.getFileStatus dir)
 #endif
-              ) `E.catch` ((\_ -> return ()) :: IOException -> IO ())
+                           `catch` ((\ _ -> return (isAlreadyExistsError e))
+                                    :: IOException -> IO Bool)
+              unless canIgnore (throwIO e)
           | otherwise              -> throwIO e
 
 #if __GLASGOW_HASKELL__
diff --git a/tests/createDirectoryIfMissing001.hs b/tests/createDirectoryIfMissing001.hs
index ec09318..bd80761 100644
--- a/tests/createDirectoryIfMissing001.hs
+++ b/tests/createDirectoryIfMissing001.hs
@@ -43,6 +43,18 @@ main = do
 
   cleanup
 
+  -- these are all supposed to fail
+
+  writeFile testdir testdir
+  report $ createDirectoryIfMissing False testdir
+  removeFile testdir
+  cleanup
+
+  writeFile testdir testdir
+  report $ createDirectoryIfMissing True testdir_a
+  removeFile testdir
+  cleanup
+
 -- createDirectoryIfMissing is allowed to fail with isDoesNotExistError if
 -- another process/thread removes one of the directories during the proces
 -- of creating the hierarchy.
diff --git a/tests/createDirectoryIfMissing001.stdout b/tests/createDirectoryIfMissing001.stdout
index f792318..d1061a8 100644
--- a/tests/createDirectoryIfMissing001.stdout
+++ b/tests/createDirectoryIfMissing001.stdout
@@ -4,3 +4,5 @@ createDirectoryIfMissing001.d/a: createDirectory: does not exist (No such file o
 ()
 ()
 ()
+createDirectoryIfMissing001.d: createDirectory: already exists (File exists)
+createDirectoryIfMissing001.d/a: createDirectory: inappropriate type (Not a directory)