Commit 17ba2dce authored by Ben Gamari's avatar Ben Gamari 🐢 Committed by GitHub

Merge pull request #36 from Mistuke/wip/inline-tmp-atomic-temp-file-windows

Inline atomic actions for Windows and write more detailed diagnostics from hsc2hs
parents 9056de46 ad5ebb90
......@@ -2,16 +2,14 @@
module Common where
import qualified Control.Exception as Exception
import qualified Compat.TempFile as Compat
import Control.Monad ( when )
import Data.Char ( isSpace )
import Data.List ( foldl' )
import System.IO
#if defined(mingw32_HOST_OS)
import Control.Concurrent ( threadDelay )
import Data.Bits ( xor )
import System.IO.Error ( isPermissionError )
import System.CPUTime ( getCPUTime )
import System.FilePath ( (</>) )
#endif
import System.Process ( createProcess, waitForProcess
, proc, CreateProcess(..), StdStream(..) )
......@@ -33,47 +31,63 @@ writeBinaryFile fp str = withBinaryFile fp WriteMode $ \h -> hPutStr h str
rawSystemL :: FilePath -> FilePath -> String -> Bool -> FilePath -> [String] -> IO ()
rawSystemL outDir outBase action flg prog args = withResponseFile outDir outBase args $ \rspFile -> do
let cmdLine = prog++" "++unwords args
when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine)
(_,_,_,ph) <- createProcess (proc prog ['@':rspFile])
when flg $ hPutStrLn stderr ("Executing: (@" ++ rspFile ++ ") " ++ cmdLine)
(_ ,_ ,progerr ,ph) <- createProcess (proc prog ['@':rspFile])
-- Because of the response files being written and removed after the process
-- terminates we now need to use process jobs here to correctly wait for all
-- child processes to terminate. Not doing so would causes a race condition
-- between the last child dieing and not holding a lock on the response file
-- and the response file getting deleted.
#if MIN_VERSION_process (1,5,0)
{ use_process_jobs = True }
{ std_err = CreatePipe
#if MIN_VERSION_process(1,5,0)
, use_process_jobs = True
#endif
}
exitStatus <- waitForProcess ph
case exitStatus of
ExitFailure exitCode -> die $ action ++ " failed "
++ "(exit code " ++ show exitCode ++ ")\n"
++ "command was: " ++ cmdLine ++ "\n"
ExitFailure exitCode ->
do errdata <- maybeReadHandle progerr
die $ action ++ " failed "
++ "(exit code " ++ show exitCode ++ ")\n"
++ "rsp file was: " ++ show rspFile ++ "\n"
++ "command was: " ++ cmdLine ++ "\n"
++ "error: " ++ errdata ++ "\n"
_ -> return ()
rawSystemWithStdOutL :: FilePath -> FilePath -> String -> Bool -> FilePath -> [String] -> FilePath -> IO ()
rawSystemWithStdOutL outDir outBase action flg prog args outFile = withResponseFile outDir outBase args $ \rspFile -> do
let cmdLine = prog++" "++unwords args++" >"++outFile
when flg (hPutStrLn stderr ("Executing: " ++ cmdLine))
when flg (hPutStrLn stderr ("Executing: (@" ++ rspFile ++ ") " ++ cmdLine))
hOut <- openFile outFile WriteMode
(_ ,_ ,_ , process) <-
(_ ,_ ,progerr , process) <-
-- We use createProcess here instead of runProcess since we need to specify
-- a custom CreateProcess structure to turn on use_process_jobs when
-- available.
createProcess
#if MIN_VERSION_process (1,5,0)
(proc prog ['@':rspFile]){ use_process_jobs = True, std_out = UseHandle hOut }
#else
(proc prog ['@':rspFile]){ std_out = UseHandle hOut }
(proc prog ['@':rspFile])
{ std_out = UseHandle hOut, std_err = CreatePipe
#if MIN_VERSION_process(1,5,0)
, use_process_jobs = True
#endif
}
exitStatus <- waitForProcess process
hClose hOut
case exitStatus of
ExitFailure exitCode -> die $ action ++ " failed "
++ "(exit code " ++ show exitCode ++ ")\n"
++ "command was: " ++ cmdLine ++ "\n"
ExitFailure exitCode ->
do errdata <- maybeReadHandle progerr
die $ action ++ " failed "
++ "(exit code " ++ show exitCode ++ ")\n"
++ "rsp file was: " ++ show rspFile ++ "\n"
++ "output file:" ++ show outFile ++ "\n"
++ "command was: " ++ cmdLine ++ "\n"
++ "error: " ++ errdata ++ "\n"
_ -> return ()
maybeReadHandle :: Maybe Handle -> IO String
maybeReadHandle Nothing = return "<no data>"
maybeReadHandle (Just h) = hGetContents h
-- delay the cleanup of generated files until the end; attempts to
-- get around intermittent failure to delete files which has
-- just been exec'ed by a sub-process (Win32 only.)
......@@ -126,43 +140,11 @@ withTempFile :: FilePath -- ^ Temp dir to create the file in
-> String -- ^ Template for temp file
-> Int -- ^ Random seed for tmp name
-> (FilePath -> Handle -> IO a) -> IO a
#if !defined(mingw32_HOST_OS)
withTempFile tmpDir _outBase template _seed action = do
Exception.bracket
(openTempFile tmpDir template)
(\(name, handle) -> do hClose handle
removeFile $ name)
(Compat.openTempFile tmpDir template)
(\(name, handle) -> finallyRemove name $ hClose handle)
(uncurry action)
#else
withTempFile tmpDir outBase template seed action = do
-- openTempFile isn't atomic under Windows. This means it's unsuitable for
-- use on Windows for creating random temp files. Instead we'll try to create
-- a reasonably random name based on the current outBase. If the
-- Sanity check to see that nothing invalidated this assumption is violated
-- then we retry a few times otherwise an error is raised.
rspFile <- findTmp 5
Exception.bracket
(openFile rspFile ReadWriteMode)
(\handle -> finallyRemove rspFile $ hClose handle)
(action rspFile)
where findTmp :: Int -> IO FilePath
findTmp 0 = die "Could not find unallocated temp file\n"
findTmp n = do
-- Generate a reasonable random number for token to prevent clashes if this
-- function is used recursively.
cpuTime <- getCPUTime
let token = show $ (fromIntegral seed) `xor` cpuTime
file = tmpDir </> (outBase ++ token ++ template)
-- Because of the resolution of the CPU timers there exists a small
-- possibility that multiple nested calls to withTempFile get the
-- same "token". To reduce the risk to almost zero we immediately
-- create the file to reserve it. If the file already exists we try
-- again.
res <- Exception.try $ openFile file ReadMode
case (res :: Either Exception.SomeException Handle) of
Left _ -> return file
Right h -> hClose h >> findTmp (n-1)
#endif
withResponseFile ::
FilePath -- ^ Working directory to create response file in.
......
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Safe #-}
#endif
module Compat.TempFile (
openBinaryTempFile,
openTempFile
) where
#if defined(mingw32_HOST_OS)
import Data.Bits
import Foreign.C.Error
import Foreign.C.String
import Foreign.C.Types
import Foreign.Ptr
import Foreign.Marshal.Alloc
import Foreign.Storable
import GHC.IO.Encoding
import GHC.IO.IOMode
import qualified GHC.IO.FD as FD
import qualified GHC.IO.Handle.FD as POSIX
import System.Posix.Internals
import System.Posix.Types
#else
import qualified System.IO as IOUtils
#endif
import GHC.IO.Handle
-- | The function creates a temporary file in ReadWrite mode.
-- The created file isn\'t deleted automatically, so you need to delete it manually.
--
-- The file is created with permissions such that only the current
-- user can read\/write it.
--
-- With some exceptions (see below), the file will be created securely
-- in the sense that an attacker should not be able to cause
-- openTempFile to overwrite another file on the filesystem using your
-- credentials, by putting symbolic links (on Unix) in the place where
-- the temporary file is to be created. On Unix the @O_CREAT@ and
-- @O_EXCL@ flags are used to prevent this attack, but note that
-- @O_EXCL@ is sometimes not supported on NFS filesystems, so if you
-- rely on this behaviour it is best to use local filesystems only.
--
openTempFile :: FilePath -- ^ Directory in which to create the file
-> String -- ^ File name template. If the template is \"foo.ext\" then
-- the created file will be \"fooXXX.ext\" where XXX is some
-- random number. Note that this should not contain any path
-- separator characters.
-> IO (FilePath, Handle)
openTempFile tmp_dir template
#if defined(mingw32_HOST_OS)
= openTempFile' "openTempFile" tmp_dir template False 0o600
#else
= IOUtils.openTempFile tmp_dir template
#endif
-- | Like 'openTempFile', but opens the file in binary mode. See 'openBinaryFile' for more comments.
openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle)
openBinaryTempFile tmp_dir template
#if defined(mingw32_HOST_OS)
= openTempFile' "openBinaryTempFile" tmp_dir template True 0o600
#else
= IOUtils.openBinaryTempFile tmp_dir template
#endif
#if defined(mingw32_HOST_OS)
openTempFile' :: String -> FilePath -> String -> Bool -> CMode
-> IO (FilePath, Handle)
openTempFile' loc tmp_dir template binary mode
| pathSeparator template
= error $ "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) =
case break (== '.') $ reverse template of
-- First case: template contains no '.'s. Just re-reverse it.
(rev_suffix, "") -> (reverse rev_suffix, "")
-- Second case: template contains at least one '.'. Strip the
-- dot from the prefix and prepend it to the suffix (if we don't
-- do this, the unique number will get added after the '.' and
-- thus be part of the extension, which is wrong.)
(rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
-- Otherwise, something is wrong, because (break (== '.')) should
-- always return a pair with either the empty string or a string
-- beginning with '.' as the second component.
_ -> error "bug in System.IO.openTempFile"
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 ->
-- 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
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 <- POSIX.mkHandleFromFD fD fd_type filename ReadWriteMode
False{-set non-block-} (Just enc)
return (filename, h)
foreign import ccall "__get_temp_file_name" c_getTempFileNameErrorNo
:: CWString -> CWString -> CWString -> CUInt -> Ptr CWchar -> IO Bool
pathSeparator :: String -> Bool
pathSeparator template = any (\x-> x == '/' || x == '\\') template
output_flags = std_flags
-- XXX Copied from GHC.Handle
std_flags, output_flags, rw_flags :: CInt
std_flags = o_NONBLOCK .|. o_NOCTTY
rw_flags = output_flags .|. o_RDWR
#endif /* mingw32_HOST_OS */
\ No newline at end of file
......@@ -79,7 +79,7 @@ withUtilsObject config outDir outBase f = do
possiblyRemove oUtilsName $ do
unless (cNoCompile config) $
rawSystemL outDir outBase ("compiling " ++ cUtilsName)
rawSystemL outDir (outBase ++ "_utils") ("compiling " ++ cUtilsName)
beVerbose
(cCompiler config)
(["-c", cUtilsName, "-o", oUtilsName] ++
......
/* ----------------------------------------------------------------------------
(c) The University of Glasgow 2006, Lifted from Bases
Useful Win32 bits
------------------------------------------------------------------------- */
#if defined(_WIN32)
#include "HsBase.h"
#include <stdbool.h>
#include <stdint.h>
/* Using Secure APIs */
#define MINGW_HAS_SECURE_API 1
#include <wchar.h>
#include <windows.h>
/* Copied from getTempFileNameErrorNo in base's cbits/Win32Utils.c in GHC 8.10.
Check there for any bugfixes first and please keep in sync when making
changes. */
bool __get_temp_file_name (wchar_t* pathName, wchar_t* prefix,
wchar_t* suffix, uint32_t uUnique,
wchar_t* tempFileName)
{
int retry = 5;
bool success = false;
while (retry > 0 && !success)
{
// TODO: This needs to handle long file names.
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);
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);
success
= MoveFileExW(temp, tempFileName, MOVEFILE_WRITE_THROUGH
| MOVEFILE_COPY_ALLOWED) != 0;
errno = 0;
if (!success && (GetLastError () != ERROR_FILE_EXISTS || --retry < 0))
{
success = false;
maperrno ();
DeleteFileW (temp);
}
free(temp);
}
free(drive);
free(dir);
free(fname);
}
return success;
}
#endif
\ No newline at end of file
## 0.68.7
- Fix race condition when using response files (#30)
- Add extra diagnostics when hsc2hs sub-process fails
and make TempFile creation fully atomic on Windows. See (#33)
## 0.68.6
......
......@@ -52,8 +52,12 @@ Executable hsc2hs
ATTParser
UtilsCodegen
Compat.ResponseFile
Compat.TempFile
Paths_hsc2hs
c-sources:
cbits/utils.c
Other-Extensions: CPP, NoMonomorphismRestriction
Build-Depends: base >= 4.3.0 && < 4.14,
......
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