[commit: base] master: Allow openTempFile to retry when it hits a directory (#4968). (6172212)

[Paolo Capriotti]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/base

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/6172212097337923b621be9e12b3542c34cad10e

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

commit 6172212097337923b621be9e12b3542c34cad10e
Author: Paolo Capriotti <p.capriotti at gmail.com>
Date:   Thu Jun 7 11:18:00 2012 +0100

    Allow openTempFile to retry when it hits a directory (#4968).
    
    Windows returns an EACCES error instead of EEXIST when a call to `open`
    fails due to an existing directory, so add a special case for this
    situation.

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

 System/IO.hs       |   28 +++++++++++++++++++++++++---
 cbits/Win32Utils.c |    6 ++++++
 2 files changed, 31 insertions(+), 3 deletions(-)

diff --git a/System/IO.hs b/System/IO.hs
index 860d2b6..57db1b0 100644
--- a/System/IO.hs
+++ b/System/IO.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE CPP, NoImplicitPrelude #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -240,6 +241,7 @@ import Data.Bits
 import Data.List
 import Data.Maybe
 import Foreign.C.Error
+import Foreign.C.String
 import Foreign.C.Types
 import System.Posix.Internals
 import System.Posix.Types
@@ -623,10 +625,30 @@ openNewFile filepath binary mode = do
   if fd < 0
     then do
       errno <- getErrno
-      if errno == eEXIST
-        then return FileExists
-        else return (OpenNewError errno)
+      case errno of
+        _ | errno == eEXIST -> return FileExists
+# ifdef mingw32_HOST_OS
+        -- If c_open throws EACCES on windows, it could mean that filepath is a
+        -- directory. In this case, we want to return FileExists so that the
+        -- enclosing openTempFile can try again instead of failing outright.
+        -- See bug #4968.
+        _ | errno == eACCES -> do
+          withCString filepath $ \path -> do
+          -- There is a race here: the directory might have been moved or
+          -- deleted between the c_open call and the next line, but there
+          -- doesn't seem to be any direct way to detect that the c_open call
+          -- failed because of an existing directory.
+          exists <- c_fileExists path
+          return $ if exists
+            then FileExists
+            else OpenNewError errno
+# endif
+        _ -> return (OpenNewError errno)
     else return (NewFileCreated fd)
+
+# ifdef mingw32_HOST_OS
+foreign import ccall "file_exists" c_fileExists :: CString -> IO Bool
+# endif
 #endif
 
 -- XXX Should use filepath library
diff --git a/cbits/Win32Utils.c b/cbits/Win32Utils.c
index 7327f45..ecd54f3 100644
--- a/cbits/Win32Utils.c
+++ b/cbits/Win32Utils.c
@@ -127,4 +127,10 @@ int get_unique_file_info(int fd, HsWord64 *dev, HsWord64 *ino)
     return -1;
 }
 
+BOOL file_exists(LPCTSTR path)
+{
+    DWORD r = GetFileAttributes(path);
+    return r != INVALID_FILE_ATTRIBUTES;
+}
+
 #endif