Commit b74bac0d authored by ttuegel's avatar ttuegel
Browse files

fix deadlock in detailed-0.9 test suite runner

Fixes #2489. The detailed-0.9 test suite runner would deadlock because
the IO manager was not draining the output pipe of the child
process. Thanks to @r0ml for the patch.
parent 71921c78
......@@ -29,8 +29,9 @@ import Distribution.TestSuite
import Distribution.Text
import Distribution.Verbosity ( normal )
import Control.Concurrent (forkIO)
import Control.Exception ( bracket )
import Control.Monad ( when, unless )
import Control.Monad ( when, unless, void )
import Data.Maybe ( mapMaybe )
import System.Directory
( createDirectoryIfMissing, doesDirectoryExist, doesFileExist
......@@ -81,6 +82,12 @@ runTest pkg_descr lbi flags suite = do
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
dataDirPath = pwd </> PD.dataDir pkg_descr
......@@ -118,9 +125,6 @@ runTest pkg_descr lbi flags suite = do
-- Write summary notice to log file indicating start of test suite
appendFile (logFile suiteLog) $ summarizeSuiteStart $ PD.testName suite
-- Append contents of temporary log file to the final human-
-- readable log file
logText <- hGetContents rOut
appendFile (logFile suiteLog) logText
-- Write end-of-suite summary notice to log file
......
......@@ -79,12 +79,12 @@ tests config version =
-- only for higher versions.
, testGroup "TestSuiteTests"
[ testGroup "ExeV10"
(PackageTests.TestSuiteTests.ExeV10.Check.checks ghcPath)
(PackageTests.TestSuiteTests.ExeV10.Check.checks config)
, testGroup "LibV09"
(PackageTests.TestSuiteTests.LibV09.Check.checks inplaceSpec ghcPath)
(PackageTests.TestSuiteTests.LibV09.Check.checks config)
]
, testCase "TestOptions" (PackageTests.TestOptions.Check.suite ghcPath)
, testCase "BenchmarkStanza" (PackageTests.BenchmarkStanza.Check.suite ghcPath)
, testCase "TestOptions" (PackageTests.TestOptions.Check.suite config)
, testCase "BenchmarkStanza" (PackageTests.BenchmarkStanza.Check.suite config)
-- ^ The benchmark stanza test will eventually be required
-- only for higher versions.
, testCase "BenchmarkExeV10/Test"
......@@ -101,8 +101,8 @@ tests config version =
, testCase "DeterministicAr"
(PackageTests.DeterministicAr.Check.suite config)
, testCase "EmptyLib/emptyLib"
(PackageTests.EmptyLib.Check.emptyLib ghcPath)
, testCase "Haddock" (PackageTests.Haddock.Check.suite ghcPath)
(PackageTests.EmptyLib.Check.emptyLib config)
, testCase "Haddock" (PackageTests.Haddock.Check.suite config)
, testCase "OrderFlags"
(PackageTests.OrderFlags.Check.suite config)
, testCase "TemplateHaskell/dynamic"
......
......@@ -24,13 +24,13 @@ import Distribution.Version (Version(..), orLaterVersion)
import PackageTests.PackageTester
checks :: FilePath -> [TestTree]
checks ghcPath =
[ testCase "Test" $ checkTest ghcPath
, testGroup "WithHpc" $ hpcTestMatrix ghcPath
checks :: SuiteConfig -> [TestTree]
checks config =
[ testCase "Test" $ checkTest config
, testGroup "WithHpc" $ hpcTestMatrix config
, testGroup "WithoutHpc"
[ testCase "NoTix" $ checkTestNoHpcNoTix ghcPath
, testCase "NoMarkup" $ checkTestNoHpcNoMarkup ghcPath
[ testCase "NoTix" $ checkTestNoHpcNoTix config
, testCase "NoMarkup" $ checkTestNoHpcNoMarkup config
]
]
......@@ -59,7 +59,7 @@ hpcTestMatrix config = do
enable cond flag
| cond = Just $ "--enable-" ++ flag
| otherwise = Nothing
return $ testCase name $ checkTestWithHpc ghcPath ("WithHpc-" ++ name) opts
return $ testCase name $ checkTestWithHpc config ("WithHpc-" ++ name) opts
dir :: FilePath
dir = "PackageTests" </> "TestSuiteTests" </> "ExeV10"
......
......@@ -9,31 +9,33 @@ import PackageTests.PackageTester
dir :: FilePath
dir = "PackageTests" </> "TestSuiteTests" </> "LibV09"
checks :: PackageSpec -> FilePath -> [TestTree]
checks inplaceSpec ghcPath =
[ testCase "Build" $ checkBuild inplaceSpec ghcPath
, localOption (mkTimeout $ 10 * 10 ^ (6 :: Int))
$ testCase "Deadlock" $ checkDeadlock inplaceSpec ghcPath
checks :: SuiteConfig -> [TestTree]
checks config =
[ testCase "Build" (checkBuild config)
, localOption (mkTimeout $ 10 ^ (8 :: Int))
$ testCase "Deadlock" (checkDeadlock config)
]
checkBuild :: PackageSpec -> FilePath -> Assertion
checkBuild inplaceSpec ghcPath = do
let spec = inplaceSpec
checkBuild :: SuiteConfig -> Assertion
checkBuild config = do
let spec = (inplaceSpec config)
{ directory = dir
, distPref = Just $ "dist-Build"
, configOpts = "--enable-tests" : configOpts inplaceSpec
, configOpts = "--enable-tests"
: configOpts (inplaceSpec config)
}
buildResult <- cabal_build spec ghcPath
buildResult <- cabal_build config spec
assertBuildSucceeded buildResult
checkDeadlock :: PackageSpec -> FilePath -> Assertion
checkDeadlock inplaceSpec ghcPath = do
let spec = inplaceSpec
checkDeadlock :: SuiteConfig -> Assertion
checkDeadlock config = do
let spec = (inplaceSpec config)
{ directory = dir
, distPref = Just $ "dist-Test"
, configOpts = "--enable-tests" : configOpts inplaceSpec
, configOpts = "--enable-tests"
: configOpts (inplaceSpec config)
}
buildResult <- cabal_build spec ghcPath
buildResult <- cabal_build config spec
assertBuildSucceeded buildResult
testResult <- cabal_test spec [] [] ghcPath
testResult <- cabal_test config spec [] []
assertTestFailed testResult
......@@ -5,4 +5,4 @@ import Distribution.TestSuite
import Lib
tests :: IO [Test]
tests = return [nullt x | x <- [1 .. 10000]]
tests = return [nullt x | x <- [1 .. 1000]]
Supports Markdown
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