From 105a46f78b0df2bea2b78ec1c9a3b7c08a84c8fd Mon Sep 17 00:00:00 2001
From: Kristen Kozak <grayjay@wordroute.com>
Date: Tue, 22 Sep 2015 16:27:04 -0700
Subject: [PATCH] Prevent detailed-0.9 test suites from freezing on Windows
(fixes #2762)
---
Cabal/Distribution/Simple/Test/LibV09.hs | 40 ++++++++++---------
Cabal/Distribution/Simple/Utils.hs | 50 ++++++++++++++++--------
2 files changed, 55 insertions(+), 35 deletions(-)
diff --git a/Cabal/Distribution/Simple/Test/LibV09.hs b/Cabal/Distribution/Simple/Test/LibV09.hs
index 859e6a9958..a2417bb53c 100644
--- a/Cabal/Distribution/Simple/Test/LibV09.hs
+++ b/Cabal/Distribution/Simple/Test/LibV09.hs
@@ -23,15 +23,14 @@ import Distribution.Simple.Setup
( TestFlags(..), TestShowDetails(..), fromFlag, configCoverage )
import Distribution.Simple.Test.Log
import Distribution.Simple.Utils
- ( die, notice, rawSystemIOWithEnv, addLibraryPath )
+ ( die, debug, notice, createProcessWithEnv, addLibraryPath )
import Distribution.System ( Platform (..) )
import Distribution.TestSuite
import Distribution.Text
import Distribution.Verbosity ( normal )
-import Control.Concurrent (forkIO)
import Control.Exception ( bracket )
-import Control.Monad ( when, unless, void )
+import Control.Monad ( when, unless )
import Data.Maybe ( mapMaybe )
import System.Directory
( createDirectoryIfMissing, doesDirectoryExist, doesFileExist
@@ -40,6 +39,7 @@ import System.Directory
import System.Exit ( ExitCode(..), exitWith )
import System.FilePath ( (</>), (<.>) )
import System.IO ( hClose, hGetContents, hPutStr )
+import System.Process (StdStream(..), waitForProcess)
runTest :: PD.PackageDescription
-> LBI.LocalBuildInfo
@@ -74,22 +74,11 @@ runTest pkg_descr lbi flags suite = do
suiteLog <- bracket openCabalTemp deleteIfExists $ \tempLog -> do
- (rIn, wIn) <- createPipe
(rOut, wOut) <- createPipe
- -- Prepare standard input for test executable
- --appendFile tempInput $ show (tempInput, PD.testName suite)
- hPutStr wIn $ show (tempLog, PD.testName suite)
- hClose wIn
-
- -- Append contents of temporary log file to the final human-
- -- readable log file
- logText <- hGetContents rOut
- -- Force the IO manager to drain the test output pipe
- void $ forkIO $ length logText `seq` return ()
-
-- Run test executable
- _ <- do let opts = map (testOption pkg_descr lbi suite) $ testOptions flags
+ (Just wIn, _, _, process) <- do
+ let opts = map (testOption pkg_descr lbi suite) $ testOptions flags
dataDirPath = pwd </> PD.dataDir pkg_descr
tixFile = pwd </> tixFilePath distPref way (PD.testName suite)
pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)
@@ -108,9 +97,22 @@ runTest pkg_descr lbi flags suite = do
True False lbi clbi
return (addLibraryPath os paths shellEnv)
else return shellEnv
- rawSystemIOWithEnv verbosity cmd opts Nothing (Just shellEnv')
- -- these handles are closed automatically
- (Just rIn) (Just wOut) (Just wOut)
+ createProcessWithEnv verbosity cmd opts Nothing (Just shellEnv')
+ -- these handles are closed automatically
+ CreatePipe (UseHandle wOut) (UseHandle wOut)
+
+ hPutStr wIn $ show (tempLog, PD.testName suite)
+ hClose wIn
+
+ -- Append contents of temporary log file to the final human-
+ -- readable log file
+ logText <- hGetContents rOut
+ -- Force the IO manager to drain the test output pipe
+ length logText `seq` return ()
+
+ exitcode <- waitForProcess process
+ unless (exitcode == ExitSuccess) $ do
+ debug verbosity $ cmd ++ " returned " ++ show exitcode
-- Generate final log file name
let finalLogName l = testLogDir
diff --git a/Cabal/Distribution/Simple/Utils.hs b/Cabal/Distribution/Simple/Utils.hs
index 1ac3c61c8a..6560ac7290 100644
--- a/Cabal/Distribution/Simple/Utils.hs
+++ b/Cabal/Distribution/Simple/Utils.hs
@@ -33,6 +33,7 @@ module Distribution.Simple.Utils (
rawSystemStdout,
rawSystemStdInOut,
rawSystemIOWithEnv,
+ createProcessWithEnv,
maybeExit,
xargs,
findProgramLocation,
@@ -197,7 +198,7 @@ import Control.Concurrent (forkIO)
import qualified System.Process as Process
( CreateProcess(..), StdStream(..), proc)
import System.Process
- ( createProcess, rawSystem, runInteractiveProcess
+ ( ProcessHandle, createProcess, rawSystem, runInteractiveProcess
, showCommandForUser, waitForProcess)
import Distribution.Compat.CopyFile
( copyFile, copyOrdinaryFile, copyExecutableFile
@@ -450,29 +451,46 @@ rawSystemIOWithEnv :: Verbosity
-> Maybe Handle -- ^ stderr
-> IO ExitCode
rawSystemIOWithEnv verbosity path args mcwd menv inp out err = do
+ (_,_,_,ph) <- createProcessWithEnv verbosity path args mcwd menv
+ (mbToStd inp) (mbToStd out) (mbToStd err)
+ exitcode <- waitForProcess ph
+ unless (exitcode == ExitSuccess) $ do
+ debug verbosity $ path ++ " returned " ++ show exitcode
+ return exitcode
+ where
+ mbToStd :: Maybe Handle -> Process.StdStream
+ mbToStd = maybe Process.Inherit Process.UseHandle
+
+createProcessWithEnv :: Verbosity
+ -> FilePath
+ -> [String]
+ -> Maybe FilePath -- ^ New working dir or inherit
+ -> Maybe [(String, String)] -- ^ New environment or inherit
+ -> Process.StdStream -- ^ stdin
+ -> Process.StdStream -- ^ stdout
+ -> Process.StdStream -- ^ stderr
+ -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
+ -- ^ Any handles created for stdin, stdout, or stderr
+ -- with 'CreateProcess', and a handle to the process.
+createProcessWithEnv verbosity path args mcwd menv inp out err = do
printRawCommandAndArgsAndEnv verbosity path args menv
hFlush stdout
- (_,_,_,ph) <- createProcess $
- (Process.proc path args) { Process.cwd = mcwd
- , Process.env = menv
- , Process.std_in = mbToStd inp
- , Process.std_out = mbToStd out
- , Process.std_err = mbToStd err
+ (inp', out', err', ph) <- createProcess $
+ (Process.proc path args) {
+ Process.cwd = mcwd
+ , Process.env = menv
+ , Process.std_in = inp
+ , Process.std_out = out
+ , Process.std_err = err
#ifdef MIN_VERSION_process
#if MIN_VERSION_process(1,2,0)
-- delegate_ctlc has been added in process 1.2, and we still want to be able to
-- bootstrap GHC on systems not having that version
- , Process.delegate_ctlc = True
+ , Process.delegate_ctlc = True
#endif
#endif
- }
- exitcode <- waitForProcess ph
- unless (exitcode == ExitSuccess) $ do
- debug verbosity $ path ++ " returned " ++ show exitcode
- return exitcode
- where
- mbToStd :: Maybe Handle -> Process.StdStream
- mbToStd = maybe Process.Inherit Process.UseHandle
+ }
+ return (inp', out', err', ph)
-- | Run a command and return its output.
--
--
GitLab