summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorHerbertValerioRiedel <>2020-03-25 21:54:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-03-25 21:54:00 (GMT)
commit93dff5b98cc6c6b2c2d9ae089a7d72d175ee1b30 (patch)
treec221488dfe5a1b0e5322a35525e455fd98001069
parentc24d68caad3b6b0c3edf2b23bcf8fd2e56c9b042 (diff)
version 0.68.7HEAD0.68.7master
-rw-r--r--Common.hs74
-rw-r--r--Compat/TempFile.hs154
-rw-r--r--UtilsCodegen.hs2
-rw-r--r--cbits/utils.c76
-rwxr-xr-xchangelog.md10
-rw-r--r--hsc2hs.cabal14
6 files changed, 293 insertions, 37 deletions
diff --git a/Common.hs b/Common.hs
index cda4828..50471b1 100644
--- a/Common.hs
+++ b/Common.hs
@@ -2,6 +2,7 @@
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' )
@@ -14,13 +15,12 @@ import System.Process ( createProcess, waitForProcess
, proc, CreateProcess(..), StdStream(..) )
import System.Exit ( ExitCode(..), exitWith )
import System.Directory ( removeFile )
-import System.FilePath ( (</>) )
die :: String -> IO a
die s = hPutStr stderr s >> exitWith (ExitFailure 1)
default_compiler :: String
-default_compiler = "gcc"
+default_compiler = "cc"
------------------------------------------------------------------------
-- Write the output files.
@@ -31,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.)
@@ -120,21 +136,15 @@ onlyOne what = die ("Only one "++what++" may be specified\n")
-- response file handling borrowed from cabal's at Distribution.Simple.Program.ResponseFile
withTempFile :: FilePath -- ^ Temp dir to create the file in
- -> FilePath -- ^ Name of the hsc file being processed
+ -> FilePath -- ^ Name of the hsc file being processed or template
+ -> String -- ^ Template for temp file
+ -> Int -- ^ Random seed for tmp name
-> (FilePath -> Handle -> IO a) -> IO a
-withTempFile tmpDir outBase action =
- -- openTempFile isn't atomic under Windows until GHC 8.10. This means it's
- -- unsuitable for use on Windows for creating random temp files. For hsc2hs
- -- this doesn't matter much since hsc2hs is single threaded and always
- -- finishes one part of its compilation pipeline before moving on to the next.
- -- This means we can just use a deterministic file as a temp file. This file
- -- will always be cleaned up before we move on to the next phase so we would
- -- never get a clash. This follows the same pattern as in DirectCodegen.hs.
+withTempFile tmpDir _outBase template _seed action = do
Exception.bracket
- (openFile rspFile ReadWriteMode)
- (\handle -> finallyRemove rspFile $ hClose handle)
- (action rspFile)
- where rspFile = tmpDir </> (outBase ++"_hsc_make.rsp")
+ (Compat.openTempFile tmpDir template)
+ (\(name, handle) -> finallyRemove name $ hClose handle)
+ (uncurry action)
withResponseFile ::
FilePath -- ^ Working directory to create response file in.
@@ -143,7 +153,7 @@ withResponseFile ::
-> (FilePath -> IO a)
-> IO a
withResponseFile workDir outBase arguments f =
- withTempFile workDir outBase $ \responseFileName hf -> do
+ withTempFile workDir outBase "hsc2hscall.rsp" (length arguments) $ \responseFileName hf -> do
let responseContents = unlines $ map escapeResponseFileArg arguments
hPutStr hf responseContents
hClose hf
diff --git a/Compat/TempFile.hs b/Compat/TempFile.hs
new file mode 100644
index 0000000..2592372
--- /dev/null
+++ b/Compat/TempFile.hs
@@ -0,0 +1,154 @@
+{-# LANGUAGE CPP #-}
+#if __GLASGOW_HASKELL__ >= 704
+{-# LANGUAGE Safe #-}
+#endif
+
+-- This module backports `openTempFile` from GHC 8.10 to hsc2hs in order to get
+-- an atomic `openTempFile` implementation on Windows when using older GHC
+-- compilers.
+-- See also https://gitlab.haskell.org/ghc/ghc/issues/10731
+--
+-- When hsc2hs supports GHC 8.10 as minimum then this module can be removed.
+module Compat.TempFile (
+ openBinaryTempFile,
+ openTempFile
+ ) where
+
+#if !MIN_VERSION_base(4,14,0) && defined(mingw32_HOST_OS)
+#define NEEDS_TEMP_WORKAROUND 1
+#else
+#define NEEDS_TEMP_WORKAROUND 0
+#endif
+
+#if NEEDS_TEMP_WORKAROUND
+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 NEEDS_TEMP_WORKAROUND
+ = 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 NEEDS_TEMP_WORKAROUND
+ = openTempFile' "openBinaryTempFile" tmp_dir template True 0o600
+#else
+ = IOUtils.openBinaryTempFile tmp_dir template
+#endif
+
+
+#if NEEDS_TEMP_WORKAROUND
+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 /* NEEDS_TEMP_WORKAROUND */
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 5ca58f8..099980f 100755
--- a/changelog.md
+++ b/changelog.md
@@ -1,3 +1,13 @@
+## 0.68.7
+
+ - The C compiler is now assumed to be called `cc` instead of `gcc`
+ by default (#42)
+
+ - 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
- Supports generation of response files to avoid system filepath
diff --git a/hsc2hs.cabal b/hsc2hs.cabal
index b7a700e..d3b00ce 100644
--- a/hsc2hs.cabal
+++ b/hsc2hs.cabal
@@ -1,6 +1,6 @@
cabal-version: >=1.10
Name: hsc2hs
-Version: 0.68.6
+Version: 0.68.7
Copyright: 2000, Marcin Kowalczyk
License: BSD3
@@ -24,7 +24,7 @@ Description:
Category: Development
Data-Files: template-hsc.h
build-type: Simple
-tested-with: GHC==8.6.4, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2, GHC==7.0.4
+tested-with: GHC==8.10.1, GHC==8.8.3, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2, GHC==7.0.4
extra-source-files:
changelog.md
@@ -52,18 +52,24 @@ 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,
+ Build-Depends: base >= 4.3.0 && < 4.15,
containers >= 0.4.0 && < 0.7,
directory >= 1.1.0 && < 1.4,
filepath >= 1.2.0 && < 1.5,
process >= 1.1.0 && < 1.7
if os(windows)
- Build-Depends: process >= 1.5.0 && < 1.7
+ -- N.B. Job object support was irreparably broken prior to 1.6.8.
+ -- See https://github.com/haskell/process/issues/167.
+ Build-Depends: process >= 1.6.8 && < 1.7
ghc-options: -Wall
if flag(in-ghc-tree)