[commit: base] ghc-7.4: Allow openTempFile to retry when it hits a directory (#4968). (35c9071)

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

On branch  : ghc-7.4

http://hackage.haskell.org/trac/ghc/changeset/35c90716b1cb13606eb002cc0d4222e07e1a629c

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

commit 35c90716b1cb13606eb002cc0d4222e07e1a629c
Author: Paolo Capriotti <[email protected]>
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.
    
    MERGED from commit 6172212097337923b621be9e12b3542c34cad10e

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

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

diff --git a/System/IO.hs b/System/IO.hs
index 860d2b6..31aa0e8 100644
--- a/System/IO.hs
+++ b/System/IO.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE CPP, NoImplicitPrelude #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -240,6 +241,9 @@ import Data.Bits
 import Data.List
 import Data.Maybe
 import Foreign.C.Error
+#ifdef mingw32_HOST_OS
+import Foreign.C.String
+#endif
 import Foreign.C.Types
 import System.Posix.Internals
 import System.Posix.Types
@@ -623,10 +627,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 fd4d1eb..d6759db 100644
--- a/cbits/Win32Utils.c
+++ b/cbits/Win32Utils.c
@@ -122,5 +122,11 @@ HsWord64 getUSecOfDay(void)
     return t;
 }
 
+BOOL file_exists(LPCTSTR path)
+{
+    DWORD r = GetFileAttributes(path);
+    return r != INVALID_FILE_ATTRIBUTES;
+}
+
 #endif