diff options
-rw-r--r-- | libraries/base/GHC/IO/Handle/Windows.hs | 2 | ||||
-rw-r--r-- | libraries/base/GHC/IO/Windows/Handle.hsc | 85 | ||||
-rw-r--r-- | libraries/base/System/IO.hs | 44 | ||||
-rw-r--r-- | libraries/base/base.cabal | 4 | ||||
-rw-r--r-- | libraries/base/cbits/Win32Utils.c | 48 |
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) |