winio: Implement new tempfile routines for winio

5 files changed, 169 insertions, 14 deletions

diff --git a/libraries/base/GHC/IO/Handle/Windows.hs b/libraries/base/GHC/IO/Handle/Windows.hs
index 3010b4d41e..e087b50570 100644
--- a/libraries/base/GHC/IO/Handle/Windows.hs
+++ b/libraries/base/GHC/IO/Handle/Windows.hs
@@ -18,7 +18,7 @@
 module GHC.IO.Handle.Windows (
   stdin, stdout, stderr,
   openFile, openBinaryFile, openFileBlocking,
-  handleToHANDLE
+  handleToHANDLE, mkHandleFromHANDLE
  ) where
 
 import Data.Maybe
diff --git a/libraries/base/GHC/IO/Windows/Handle.hsc b/libraries/base/GHC/IO/Windows/Handle.hsc
index a970743b68..d96ccc364e 100644
--- a/libraries/base/GHC/IO/Windows/Handle.hsc
+++ b/libraries/base/GHC/IO/Windows/Handle.hsc
@@ -42,6 +42,7 @@ module GHC.IO.Windows.Handle
 
    -- * File utilities
    openFile,
+   openFileAsTemp,
    release
  ) where
 
@@ -858,13 +859,83 @@ openFile filepath iomode non_blocking =
                                       file_create_flags
                                       nullPtr
 
-          -- Tell the OS that we support skipping the request Queue if the
-          -- IRQ can be handled immediately, e.g. if the data is in the cache.
-          optimizeFileAccess handle =
-              failIfFalse_ "SetFileCompletionNotificationModes"  $
-                c_SetFileCompletionNotificationModes handle
-                    (    #{const FILE_SKIP_COMPLETION_PORT_ON_SUCCESS}
-                     .|. #{const FILE_SKIP_SET_EVENT_ON_HANDLE})
+-- | Open a file as a temporary file and make an 'NativeHandle' for it.
+-- Truncates the file to zero size when the `IOMode` is `WriteMode`.
+openFileAsTemp
+  :: FilePath -- ^ file to open
+  -> Bool     -- ^ open the file in non-blocking mode?
+  -> Bool     -- ^ Exclusive mode
+  -> IO (Io NativeHandle, IODeviceType)
+openFileAsTemp filepath non_blocking excl =
+   do devicepath <- getDevicePath filepath
+      h <- createFile devicepath
+      -- Attach the handle to the I/O manager's CompletionPort.  This allows the
+      -- I/O manager to service requests for this Handle.
+      Mgr.associateHandle' h
+      let hwnd = fromHANDLE h
+      _type <- devType hwnd
+
+      -- Use the rts to enforce any file locking we may need.
+      let write_lock = True
+
+      case _type of
+        -- Regular files need to be locked.
+        RegularFile -> do
+          optimizeFileAccess h -- Set a few optimization flags on file handles.
+          (unique_dev, unique_ino) <- getUniqueFileInfo hwnd
+          r <- lockFile (fromIntegral $ ptrToWordPtr h) unique_dev unique_ino
+                        (fromBool write_lock)
+          when (r == -1)  $
+               ioException (IOError Nothing ResourceBusy "openFile"
+                                  "file is locked" Nothing Nothing)
+
+        _ -> return ()
+
+      return (hwnd, _type)
+        where
+          -- We have to use in-process locking (e.g. use the locking mechanism
+          -- in the rts) so we're consistent with the linux behavior and the
+          -- rts knows about the lock.  See #4363 for more.
+          file_share_mode =  #{const FILE_SHARE_READ}
+                         .|. #{const FILE_SHARE_DELETE}
+
+          file_access_mode =  #{const GENERIC_READ}
+                            .|. #{const GENERIC_WRITE}
+
+          file_open_mode =
+            case excl of
+              True      -> #{const CREATE_NEW}    -- O_CREAT | O_RDWR | O_EXCL
+              False     -> #{const CREATE_ALWAYS} -- O_CREAT | O_RDWR
+
+          file_create_flags =
+            if non_blocking
+               then #{const FILE_FLAG_OVERLAPPED}
+                    -- Open temp files sequentially
+                    .|. #{const FILE_FLAG_SEQUENTIAL_SCAN}
+                    -- Hold data in cache for as long as possible
+                    .|. #{const FILE_ATTRIBUTE_TEMPORARY}
+               else #{const FILE_ATTRIBUTE_NORMAL}
+                    -- Hold data in cache for as long as possible
+                    .|. #{const FILE_ATTRIBUTE_TEMPORARY}
+
+          createFile devicepath =
+            withCWString devicepath $ \fp ->
+                failIf (== iNVALID_HANDLE_VALUE) "CreateFile" $
+                      c_CreateFile fp file_access_mode
+                                      file_share_mode
+                                      nullPtr
+                                      file_open_mode
+                                      file_create_flags
+                                      nullPtr
+
+-- Tell the OS that we support skipping the request Queue if the
+-- IRQ can be handled immediately, e.g. if the data is in the cache.
+optimizeFileAccess :: HANDLE -> IO ()
+optimizeFileAccess handle =
+    failIfFalse_ "SetFileCompletionNotificationModes"  $
+      c_SetFileCompletionNotificationModes handle
+          (    #{const FILE_SKIP_COMPLETION_PORT_ON_SUCCESS}
+            .|. #{const FILE_SKIP_SET_EVENT_ON_HANDLE})
 
 release :: RawHandle a => a -> IO ()
 release h = if isLockable h
diff --git a/libraries/base/System/IO.hs b/libraries/base/System/IO.hs
index c5c0f15414..9a2d0ce69a 100644
--- a/libraries/base/System/IO.hs
+++ b/libraries/base/System/IO.hs
@@ -232,6 +232,12 @@ import Foreign.C.String
 import Foreign.Ptr
 import Foreign.Marshal.Alloc
 import Foreign.Storable
+import GHC.IO.SubSystem
+import GHC.IO.Windows.Handle (openFileAsTemp)
+import GHC.IO.Handle.Windows (mkHandleFromHANDLE)
+import GHC.IO.Device as IODevice
+import GHC.Real (fromIntegral)
+import Foreign.Marshal.Utils (new)
 #endif
 import Foreign.C.Types
 import System.Posix.Internals
@@ -530,13 +536,29 @@ openTempFile' loc tmp_dir template binary mode
          -- beginning with '.' as the second component.
          _                      -> errorWithoutStackTrace "bug in System.IO.openTempFile"
 #if defined(mingw32_HOST_OS)
-    findTempName = do
+    findTempName = findTempNamePosix <!> findTempNameWinIO
+
+    findTempNameWinIO = do
+      let label = if null prefix then "ghc" else prefix
+      withCWString tmp_dir $ \c_tmp_dir ->
+        withCWString label $ \c_template ->
+          withCWString suffix $ \c_suffix -> do
+            c_ptr <- new nullPtr
+            res <- c_createUUIDTempFileErrNo c_tmp_dir c_template c_suffix
+                                             c_ptr
+            if not res
+               then do errno <- getErrno
+                       ioError (errnoToIOError loc errno Nothing (Just tmp_dir))
+               else do c_p <- peek c_ptr
+                       filename <- peekCWString c_p
+                       free c_p
+                       handleResultsWinIO filename ((fromIntegral mode .&. o_EXCL) == o_EXCL)
+
+    findTempNamePosix = do
       let label = if null prefix then "ghc" else prefix
       withCWString tmp_dir $ \c_tmp_dir ->
         withCWString label $ \c_template ->
           withCWString suffix $ \c_suffix ->
-            -- FIXME: revisit this when new I/O manager in place and use a UUID
-            --       based one when we are no longer MAX_PATH bound.
             allocaBytes (sizeOf (undefined :: CWchar) * 260) $ \c_str -> do
             res <- c_getTempFileNameErrorNo c_tmp_dir c_template c_suffix 0
                                             c_str
@@ -544,9 +566,9 @@ openTempFile' loc tmp_dir template binary mode
                then do errno <- getErrno
                        ioError (errnoToIOError loc errno Nothing (Just tmp_dir))
                else do filename <- peekCWString c_str
-                       handleResults filename
+                       handleResultsPosix filename
 
-    handleResults filename = do
+    handleResultsPosix filename = do
       let oflags1 = rw_flags .|. o_EXCL
           binary_flags
               | binary    = o_BINARY
@@ -567,9 +589,21 @@ openTempFile' loc tmp_dir template binary mode
 
              return (filename, h)
 
+    handleResultsWinIO filename excl = do
+      (hwnd, hwnd_type) <- openFileAsTemp filename True excl
+      mb_codec <- if binary then return Nothing else fmap Just getLocaleEncoding
+
+      -- then use it to make a Handle
+      h <- mkHandleFromHANDLE hwnd hwnd_type filename ReadWriteMode mb_codec
+                `onException` IODevice.close hwnd
+      return (filename, h)
+
 foreign import ccall "getTempFileNameErrorNo" c_getTempFileNameErrorNo
   :: CWString -> CWString -> CWString -> CUInt -> Ptr CWchar -> IO Bool
 
+foreign import ccall "__createUUIDTempFileErrNo" c_createUUIDTempFileErrNo
+  :: CWString -> CWString -> CWString -> Ptr CWString -> IO Bool
+
 pathSeparator :: String -> Bool
 pathSeparator template = any (\x-> x == '/' || x == '\\') template
 
diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal
index 5342e86616..591368931e 100644
--- a/libraries/base/base.cabal
+++ b/libraries/base/base.cabal
@@ -375,8 +375,10 @@ Library
         --          mingw32 which is required by mingwex.
         -- shlwapi: provides PathFileExistsW
         -- ws2_32: provides access to socket types and functions
+        -- ole32: provides UUID functionality.
+        -- rpcrt4: provides RPC UUID creation.
         extra-libraries: wsock32, user32, shell32, msvcrt, mingw32,
-                         mingwex, ws2_32, shlwapi
+                         mingwex, ws2_32, shlwapi, ole32, rpcrt4
         -- Minimum supported Windows version.
         -- These numbers can be found at:
         --  https://msdn.microsoft.com/en-us/library/windows/desktop/aa383745(v=vs.85).aspx
diff --git a/libraries/base/cbits/Win32Utils.c b/libraries/base/cbits/Win32Utils.c
index 7b9c9cd244..4181e6105f 100644
--- a/libraries/base/cbits/Win32Utils.c
+++ b/libraries/base/cbits/Win32Utils.c
@@ -16,6 +16,8 @@
 #include <wchar.h>
 #include <windows.h>
 #include <io.h>
+#include <objbase.h>
+#include "fs.h"
 
 /* This is the error table that defines the mapping between OS error
    codes and errno values */
@@ -162,6 +164,52 @@ BOOL file_exists(LPCTSTR path)
     return r != INVALID_FILE_ATTRIBUTES;
 }
 
+/* If true then caller needs to free tempFileName.  */
+bool __createUUIDTempFileErrNo (wchar_t* pathName, wchar_t* prefix,
+                                wchar_t* suffix, wchar_t** tempFileName)
+{
+  int retry = 5;
+  bool success = false;
+  while (retry-- > 0 && !success)
+    {
+      GUID guid;
+      ZeroMemory (&guid, sizeof (guid));
+      if (CoCreateGuid (&guid) != S_OK)
+        goto fail;
+
+      RPC_WSTR guidStr;
+      if (UuidToStringW ((UUID*)&guid, &guidStr) != S_OK)
+        goto fail;
+
+      wchar_t* devName = FS(create_device_name) ((wchar_t*)pathName);
+      int len = wcslen (devName) + wcslen (suffix) + wcslen (prefix)
+              + wcslen (guidStr) + 3;
+      *tempFileName = malloc (len * sizeof (wchar_t));
+      if (*tempFileName == NULL)
+        goto fail;
+
+      if (-1 == swprintf_s (*tempFileName, len, L"%ls\\%ls-%ls%ls",
+                            devName, prefix, guidStr, suffix))
+        goto fail;
+
+      free (devName);
+      RpcStringFreeW (&guidStr);
+      /* This should never happen because GUIDs are unique.  But in case hell
+         froze over let's check anyway.  */
+      DWORD dwAttrib = GetFileAttributesW (*tempFileName);
+      success = (dwAttrib == INVALID_FILE_ATTRIBUTES
+                 || (dwAttrib & FILE_ATTRIBUTE_DIRECTORY));
+      if (!success)
+        free (*tempFileName);
+    }
+
+  return success;
+
+fail:
+  maperrno();
+  return false;
+}
+
 bool getTempFileNameErrorNo (wchar_t* pathName, wchar_t* prefix,
                              wchar_t* suffix, uint32_t uUnique,
                              wchar_t* tempFileName)