From a5a4707ac16fdffb9f0aaed2c28c59952830fc27 Mon Sep 17 00:00:00 2001
From: Tamar Christina <tamar@zhox.com>
Date: Sun, 6 Oct 2019 00:24:46 +0100
Subject: [PATCH] Inline atomic actions for Windows and write more detailed
diagnostics from hsc2hs
---
Common.hs | 88 +++++++++++-----------------
Compat/TempFile.hs | 142 +++++++++++++++++++++++++++++++++++++++++++++
UtilsCodegen.hs | 2 +-
cbits/utils.c | 76 ++++++++++++++++++++++++
changelog.md | 2 +
hsc2hs.cabal | 4 ++
6 files changed, 260 insertions(+), 54 deletions(-)
create mode 100644 Compat/TempFile.hs
create mode 100644 cbits/utils.c
diff --git a/Common.hs b/Common.hs
index a79d485..c8bd297 100644
--- a/Common.hs
+++ b/Common.hs
@@ -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.
diff --git a/Compat/TempFile.hs b/Compat/TempFile.hs
new file mode 100644
index 0000000..799484e
--- /dev/null
+++ b/Compat/TempFile.hs
@@ -0,0 +1,142 @@
+{-# LANGUAGE CPP #-}
+#if __GLASGOW_HASKELL__ >= 70
+{-# 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
diff --git a/UtilsCodegen.hs b/UtilsCodegen.hs
index 0e35614..36305f3 100644
--- a/UtilsCodegen.hs
+++ b/UtilsCodegen.hs
@@ -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] ++
diff --git a/cbits/utils.c b/cbits/utils.c
new file mode 100644
index 0000000..d9f9461
--- /dev/null
+++ b/cbits/utils.c
@@ -0,0 +1,76 @@
+/* ----------------------------------------------------------------------------
+ (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
diff --git a/changelog.md b/changelog.md
index 100c2c2..495e6a6 100644
--- a/changelog.md
+++ b/changelog.md
@@ -1,6 +1,8 @@
## 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
diff --git a/hsc2hs.cabal b/hsc2hs.cabal
index f87b757..a2dfd3f 100644
--- a/hsc2hs.cabal
+++ b/hsc2hs.cabal
@@ -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,
--
GitLab