Commit 2fc621df authored by Tamar Christina's avatar Tamar Christina Committed by Ben Gamari
Browse files

Make System.IO.openTempFile thread-safe on Windows

This calls out to the Win32 API `GetTempFileName` to generate
a temporary file. Using `uUnique = 0` guarantees that the file
we get back is unique and the file is "reserved" by creating it.

Test Plan:
./validate

I can't think of any sensible tests that shouldn't run for a while
to verify. So the example in #10731 was ran for a while and no
collisions in new code

Reviewers: hvr, bgamari, erikd

Reviewed By: bgamari

Subscribers: RyanGlScott, rwbarton, thomie, carter

GHC Trac Issues: #10731

Differential Revision: https://phabricator.haskell.org/D4278

(cherry picked from commit 46287af0)
parent 1779e3bf
......@@ -226,6 +226,9 @@ import Data.Maybe
import Foreign.C.Error
#if defined(mingw32_HOST_OS)
import Foreign.C.String
import Foreign.Ptr
import Foreign.Marshal.Alloc
import Foreign.Storable
#endif
import Foreign.C.Types
import System.Posix.Internals
......@@ -233,7 +236,9 @@ import System.Posix.Types
import GHC.Base
import GHC.List
#ifndef mingw32_HOST_OS
import GHC.IORef
#endif
import GHC.Num
import GHC.IO hiding ( bracket, onException )
import GHC.IO.IOMode
......@@ -478,14 +483,14 @@ openBinaryTempFileWithDefaultPermissions tmp_dir template
openTempFile' :: String -> FilePath -> String -> Bool -> CMode
-> IO (FilePath, Handle)
openTempFile' loc tmp_dir template binary mode
| pathSeparator `elem` template
| pathSeparator template
= fail $ "openTempFile': Template string must not contain path separator characters: "++template
| otherwise = findTempName
where
-- We split off the last extension, so we can use .foo.ext files
-- for temporary files (hidden on Unix OSes). Unfortunately we're
-- below filepath in the hierarchy here.
(prefix,suffix) =
(prefix, suffix) =
case break (== '.') $ reverse template of
-- First case: template contains no '.'s. Just re-reverse it.
(rev_suffix, "") -> (reverse rev_suffix, "")
......@@ -498,7 +503,52 @@ openTempFile' loc tmp_dir template binary mode
-- always return a pair with either the empty string or a string
-- beginning with '.' as the second component.
_ -> errorWithoutStackTrace "bug in System.IO.openTempFile"
#if defined(mingw32_HOST_OS)
findTempName = do
let label = if null prefix then "ghc" else prefix
withCWString tmp_dir $ \c_tmp_dir ->
withCWString label $ \c_template ->
withCWString suffix $ \c_suffix ->
-- NOTE: 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
if not res
then do errno <- getErrno
ioError (errnoToIOError loc errno Nothing (Just tmp_dir))
else do filename <- peekCWString c_str
handleResults filename
handleResults filename = do
let oflags1 = rw_flags .|. o_EXCL
binary_flags
| binary = o_BINARY
| otherwise = 0
oflags = oflags1 .|. binary_flags
fd <- withFilePath filename $ \ f -> c_open f oflags mode
case fd < 0 of
True -> do errno <- getErrno
ioError (errnoToIOError loc errno Nothing (Just tmp_dir))
False ->
do (fD,fd_type) <- FD.mkFD fd ReadWriteMode Nothing{-no stat-}
False{-is_socket-}
True{-is_nonblock-}
enc <- getLocaleEncoding
h <- mkHandleFromFD fD fd_type filename ReadWriteMode
False{-set non-block-} (Just enc)
return (filename, h)
foreign import ccall "getTempFileNameErrorNo" c_getTempFileNameErrorNo
:: CWString -> CWString -> CWString -> CUInt -> Ptr CWchar -> IO Bool
pathSeparator :: String -> Bool
pathSeparator template = any (\x-> x == '/' || x == '\\') template
output_flags = std_flags
#else /* else mingw32_HOST_OS */
findTempName = do
rs <- rand_string
let filename = prefix ++ rs ++ suffix
......@@ -522,8 +572,8 @@ openTempFile' loc tmp_dir template binary mode
combine a b
| null b = a
| null a = b
| last a == pathSeparator = a ++ b
| otherwise = a ++ [pathSeparator] ++ b
| pathSeparator [last a] = a ++ b
| otherwise = a ++ [pathSeparatorChar] ++ b
tempCounter :: IORef Int
tempCounter = unsafePerformIO $ newIORef 0
......@@ -557,41 +607,22 @@ openNewFile filepath binary mode = do
errno <- getErrno
case errno of
_ | errno == eEXIST -> return FileExists
#if defined(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)
#if defined(mingw32_HOST_OS)
foreign import ccall "file_exists" c_fileExists :: CString -> IO Bool
#endif
-- XXX Should use filepath library
pathSeparator :: Char
#if defined(mingw32_HOST_OS)
pathSeparator = '\\'
#else
pathSeparator = '/'
#endif
pathSeparatorChar :: Char
pathSeparatorChar = '/'
pathSeparator :: String -> Bool
pathSeparator template = pathSeparatorChar `elem` template
output_flags = std_flags .|. o_CREAT
#endif /* mingw32_HOST_OS */
-- XXX Copied from GHC.Handle
std_flags, output_flags, rw_flags :: CInt
std_flags = o_NONBLOCK .|. o_NOCTTY
output_flags = std_flags .|. o_CREAT
rw_flags = output_flags .|. o_RDWR
-- $locking
......@@ -611,4 +642,3 @@ rw_flags = output_flags .|. o_RDWR
-- It follows that an attempt to write to a file (using 'writeFile', for
-- example) that was earlier opened by 'readFile' will usually result in
-- failure with 'System.IO.Error.isAlreadyInUseError'.
......@@ -7,6 +7,10 @@
#if defined(_WIN32)
#include "HsBase.h"
#include <stdbool.h>
#include <stdint.h>
#include <wchar.h>
#include <windows.h>
/* This is the error table that defines the mapping between OS error
codes and errno values */
......@@ -148,4 +152,43 @@ BOOL file_exists(LPCTSTR path)
return r != INVALID_FILE_ATTRIBUTES;
}
bool getTempFileNameErrorNo (wchar_t* pathName, wchar_t* prefix,
wchar_t* suffix, uint32_t uUnique,
wchar_t* tempFileName)
{
if (!GetTempFileNameW(pathName, prefix, uUnique, tempFileName))
{
maperrno();
return false;
}
wchar_t* drive = malloc (sizeof(wchar_t) * _MAX_DRIVE);
wchar_t* dir = malloc (sizeof(wchar_t) * _MAX_DIR);
wchar_t* fname = malloc (sizeof(wchar_t) * _MAX_FNAME);
bool success = true;
if (_wsplitpath_s (tempFileName, drive, _MAX_DRIVE, dir, _MAX_DIR,
fname, _MAX_FNAME, NULL, 0) != 0)
{
success = false;
maperrno ();
}
else
{
wchar_t* temp = _wcsdup (tempFileName);
if (wcsnlen(drive, _MAX_DRIVE) == 0)
swprintf_s(tempFileName, MAX_PATH, L"%s\%s%s",
dir, fname, suffix);
else
swprintf_s(tempFileName, MAX_PATH, L"%s\%s\%s%s",
drive, dir, fname, suffix);
MoveFileW(temp, tempFileName);
free(temp);
}
free(drive);
free(dir);
free(fname);
return success;
}
#endif
# Changelog for [`base` package](http://hackage.haskell.org/package/base)
## 4.11.1.0 *TBA*
* `System.IO.openTempFile` is now thread-safe on Windows.
## 4.11.0.0 *TBA*
* Bundled with GHC 8.4.1
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment