From 1f113935439a381443b945eb5177fb122881f182 Mon Sep 17 00:00:00 2001
From: Herbert Valerio Riedel <hvr@gnu.org>
Date: Mon, 19 Jan 2015 14:18:09 +0100
Subject: [PATCH] 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)
---
 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 98e4c205..26600a06 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 ec093185..bd80761b 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 f792318d..d1061a81 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)