From 3c19578c23fcdd4794d87b756f9371a26454e11f Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Mon, 1 Jun 2020 10:58:02 +0300 Subject: [PATCH] Use process createPipe, make compat variant compat. If we need localeEncoding, that can be set outside. Also add rawSystemIOWithEnvAndAction to allow draining the spawned process output without async (in a simple case of single output Handle). --- Cabal/Cabal.cabal | 2 + Cabal/Distribution/Compat/CreatePipe.hs | 14 +++-- Cabal/Distribution/Simple/Test/ExeV10.hs | 59 +++++++++++-------- Cabal/Distribution/Simple/Test/LibV09.hs | 17 ++++-- Cabal/Distribution/Simple/Utils.hs | 24 ++++++++ .../Distribution/Compat/CreatePipe.hs | 53 ++++++++++++++--- 6 files changed, 125 insertions(+), 44 deletions(-) diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index 35bff084130..590c6e177ad 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -669,10 +669,12 @@ test-suite unit-tests main-is: UnitTests.hs build-depends: array, + async >= 2.2.2 && <2.3, base, binary, bytestring, containers, + deepseq, directory, filepath, integer-logarithms >= 1.0.2 && <1.1, diff --git a/Cabal/Distribution/Compat/CreatePipe.hs b/Cabal/Distribution/Compat/CreatePipe.hs index e72e5ccc795..f3b18fa09f0 100644 --- a/Cabal/Distribution/Compat/CreatePipe.hs +++ b/Cabal/Distribution/Compat/CreatePipe.hs @@ -4,7 +4,10 @@ module Distribution.Compat.CreatePipe (createPipe) where -import System.IO (Handle, hSetEncoding, localeEncoding) +#if MIN_VERSION_process(1,2,1) +import System.Process (createPipe) +#else +import System.IO (Handle, hSetBinaryMode) import Prelude () import Distribution.Compat.Prelude @@ -40,8 +43,8 @@ createPipe = do return (readfd, writefd) (do readh <- fdToHandle readfd ReadMode writeh <- fdToHandle writefd WriteMode - hSetEncoding readh localeEncoding - hSetEncoding writeh localeEncoding + hSetBinaryMode readh True + hSetBinaryMode writeh True return (readh, writeh)) `onException` (close readfd >> close writefd) where fdToHandle :: CInt -> IOMode -> IO Handle @@ -69,9 +72,10 @@ createPipe = do (readfd, writefd) <- Posix.createPipe readh <- fdToHandle readfd writeh <- fdToHandle writefd - hSetEncoding readh localeEncoding - hSetEncoding writeh localeEncoding + hSetBinaryMode readh True + hSetBinaryMode writeh True return (readh, writeh) where _ = callStack #endif +#endif diff --git a/Cabal/Distribution/Simple/Test/ExeV10.hs b/Cabal/Distribution/Simple/Test/ExeV10.hs index f242bf6e1fe..6010480ab3a 100644 --- a/Cabal/Distribution/Simple/Test/ExeV10.hs +++ b/Cabal/Distribution/Simple/Test/ExeV10.hs @@ -27,12 +27,13 @@ import Distribution.TestSuite import Distribution.Pretty import Distribution.Verbosity -import Control.Concurrent (forkIO) import System.Directory ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist , getCurrentDirectory, removeDirectoryRecursive ) import System.FilePath ( (), (<.>) ) -import System.IO ( hGetContents, stdout, stderr ) +import System.IO ( stdout, stderr ) + +import qualified Data.ByteString.Lazy as LBS runTest :: PD.PackageDescription -> LBI.LocalBuildInfo @@ -66,20 +67,6 @@ runTest pkg_descr lbi clbi flags suite = do -- Write summary notices indicating start of test suite notice verbosity $ summarizeSuiteStart $ testName' - (wOut, wErr, logText) <- case details of - Direct -> return (stdout, stderr, "") - _ -> do - (rOut, wOut) <- createPipe - - -- Read test executable's output lazily (returns immediately) - logText <- hGetContents rOut - -- Force the IO manager to drain the test output pipe - void $ forkIO $ length logText `seq` return () - - -- '--show-details=streaming': print the log output in another thread - when (details == Streaming) $ void $ forkIO $ putStr logText - - return (wOut, wOut, logText) -- Run the test executable let opts = map (testOption pkg_descr lbi suite) @@ -97,14 +84,34 @@ runTest pkg_descr lbi clbi flags suite = do return (addLibraryPath os paths shellEnv) else return shellEnv - exit <- case testWrapper flags of - Flag path -> rawSystemIOWithEnv verbosity path (cmd:opts) Nothing (Just shellEnv') - -- these handles are automatically closed - Nothing (Just wOut) (Just wErr) + -- Output logger + (wOut, wErr, getLogText) <- case details of + Direct -> return (stdout, stderr, return LBS.empty) + _ -> do + (rOut, wOut) <- createPipe + + return $ (,,) wOut wOut $ do + -- Read test executables' output + logText <- LBS.hGetContents rOut + + -- '--show-details=streaming': print the log output in another thread + when (details == Streaming) $ LBS.putStr logText + + -- drain the output. + evaluate (force logText) + + (exit, logText) <- case testWrapper flags of + Flag path -> rawSystemIOWithEnvAndAction + verbosity path (cmd:opts) Nothing (Just shellEnv') + getLogText + -- these handles are automatically closed + Nothing (Just wOut) (Just wErr) - NoFlag -> rawSystemIOWithEnv verbosity cmd opts Nothing (Just shellEnv') - -- these handles are automatically closed - Nothing (Just wOut) (Just wErr) + NoFlag -> rawSystemIOWithEnvAndAction + verbosity cmd opts Nothing (Just shellEnv') + getLogText + -- these handles are automatically closed + Nothing (Just wOut) (Just wErr) -- Generate TestSuiteLog from executable exit code and a machine- -- readable test log. @@ -115,7 +122,7 @@ runTest pkg_descr lbi clbi flags suite = do -- Append contents of temporary log file to the final human- -- readable log file - appendFile (logFile suiteLog) logText + LBS.appendFile (logFile suiteLog) logText -- Write end-of-suite summary notice to log file appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog @@ -127,7 +134,9 @@ runTest pkg_descr lbi clbi flags suite = do details == Failures && not (suitePassed $ testLogs suiteLog)) -- verbosity overrides show-details && verbosity >= normal - whenPrinting $ putStr $ unlines $ lines logText + whenPrinting $ do + LBS.putStr logText + putChar '\n' -- Write summary notice to terminal indicating end of test suite notice verbosity $ summarizeSuiteFinish suiteLog diff --git a/Cabal/Distribution/Simple/Test/LibV09.hs b/Cabal/Distribution/Simple/Test/LibV09.hs index f9ebc9e1140..ef111cfb611 100644 --- a/Cabal/Distribution/Simple/Test/LibV09.hs +++ b/Cabal/Distribution/Simple/Test/LibV09.hs @@ -34,13 +34,14 @@ import Distribution.Pretty import Distribution.Verbosity import qualified Control.Exception as CE +import qualified Data.ByteString.Lazy as LBS import System.Directory ( createDirectoryIfMissing, canonicalizePath , doesDirectoryExist, doesFileExist , getCurrentDirectory, removeDirectoryRecursive, removeFile , setCurrentDirectory ) import System.FilePath ( (), (<.>) ) -import System.IO ( hClose, hGetContents, hPutStr ) +import System.IO ( hClose, hPutStr ) import System.Process (StdStream(..), waitForProcess) runTest :: PD.PackageDescription @@ -78,6 +79,8 @@ runTest pkg_descr lbi clbi flags suite = do suiteLog <- CE.bracket openCabalTemp deleteIfExists $ \tempLog -> do + -- TODO: this setup is broken, + -- if the test output is too big, we will deadlock. (rOut, wOut) <- createPipe -- Run test executable @@ -112,9 +115,9 @@ runTest pkg_descr lbi clbi flags suite = do -- Append contents of temporary log file to the final human- -- readable log file - logText <- hGetContents rOut + logText <- LBS.hGetContents rOut -- Force the IO manager to drain the test output pipe - length logText `seq` return () + _ <- evaluate (force logText) exitcode <- waitForProcess process unless (exitcode == ExitSuccess) $ do @@ -134,7 +137,7 @@ runTest pkg_descr lbi clbi flags suite = do -- Write summary notice to log file indicating start of test suite appendFile (logFile suiteLog) $ summarizeSuiteStart testName' - appendFile (logFile suiteLog) logText + LBS.appendFile (logFile suiteLog) logText -- Write end-of-suite summary notice to log file appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog @@ -145,7 +148,9 @@ runTest pkg_descr lbi clbi flags suite = do whenPrinting = when $ (details > Never) && (not (suitePassed $ testLogs suiteLog) || details == Always) && verbosity >= normal - whenPrinting $ putStr $ unlines $ lines logText + whenPrinting $ do + LBS.putStr logText + putChar '\n' return suiteLog @@ -158,7 +163,7 @@ runTest pkg_descr lbi clbi flags suite = do return suiteLog where testName' = unUnqualComponentName $ PD.testName suite - + deleteIfExists file = do exists <- doesFileExist file when exists $ removeFile file diff --git a/Cabal/Distribution/Simple/Utils.hs b/Cabal/Distribution/Simple/Utils.hs index d7c55951b39..3b29d96c79a 100644 --- a/Cabal/Distribution/Simple/Utils.hs +++ b/Cabal/Distribution/Simple/Utils.hs @@ -50,6 +50,7 @@ module Distribution.Simple.Utils ( rawSystemStdout, rawSystemStdInOut, rawSystemIOWithEnv, + rawSystemIOWithEnvAndAction, createProcessWithEnv, maybeExit, xargs, @@ -765,6 +766,29 @@ rawSystemIOWithEnv verbosity path args mcwd menv inp out err = withFrozenCallSta mbToStd :: Maybe Handle -> Process.StdStream mbToStd = maybe Process.Inherit Process.UseHandle +rawSystemIOWithEnvAndAction + :: Verbosity + -> FilePath + -> [String] + -> Maybe FilePath -- ^ New working dir or inherit + -> Maybe [(String, String)] -- ^ New environment or inherit + -> IO a -- ^ action to perform after process is created, but before 'waitForProcess'. + -> Maybe Handle -- ^ stdin + -> Maybe Handle -- ^ stdout + -> Maybe Handle -- ^ stderr + -> IO (ExitCode, a) +rawSystemIOWithEnvAndAction verbosity path args mcwd menv action inp out err = withFrozenCallStack $ do + (_,_,_,ph) <- createProcessWithEnv verbosity path args mcwd menv + (mbToStd inp) (mbToStd out) (mbToStd err) + a <- action + exitcode <- waitForProcess ph + unless (exitcode == ExitSuccess) $ do + debug verbosity $ path ++ " returned " ++ show exitcode + return (exitcode, a) + where + mbToStd :: Maybe Handle -> Process.StdStream + mbToStd = maybe Process.Inherit Process.UseHandle + createProcessWithEnv :: Verbosity -> FilePath diff --git a/Cabal/tests/UnitTests/Distribution/Compat/CreatePipe.hs b/Cabal/tests/UnitTests/Distribution/Compat/CreatePipe.hs index 2e7929d34e2..d192d6fe33c 100644 --- a/Cabal/tests/UnitTests/Distribution/Compat/CreatePipe.hs +++ b/Cabal/tests/UnitTests/Distribution/Compat/CreatePipe.hs @@ -1,19 +1,56 @@ module UnitTests.Distribution.Compat.CreatePipe (tests) where +import Control.Concurrent.Async (async, wait) +import Control.DeepSeq (force) +import Control.Exception (evaluate) +import System.IO (hClose, hGetContents, hPutStr, hSetEncoding, localeEncoding) +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (Assertion, assertEqual, testCase) + +import qualified Data.ByteString as BS + import Distribution.Compat.CreatePipe -import System.IO (hClose, hGetContents, hPutStr, hSetEncoding, localeEncoding) -import Test.Tasty -import Test.Tasty.HUnit tests :: [TestTree] -tests = [testCase "Locale Encoding" case_Locale_Encoding] +tests = + [ testCase "Locale Encoding" case_Locale_Encoding + , testCase "Binary ByteStrings are not affected" case_ByteString + ] case_Locale_Encoding :: Assertion case_Locale_Encoding = do - let str = "\0252" + let str = "\0252foobar" (r, w) <- createPipe hSetEncoding w localeEncoding - out <- hGetContents r - hPutStr w str - hClose w + hSetEncoding r localeEncoding + + ra <- async $ do + out <- hGetContents r + evaluate (force out) + + wa <- async $ do + hPutStr w str + hClose w + + out <- wait ra + wait wa + assertEqual "createPipe should support Unicode roundtripping" str out + +case_ByteString :: Assertion +case_ByteString = do + let bs = BS.pack[ 1..255] + (r, w) <- createPipe + + ra <- async $ do + out <- BS.hGetContents r + evaluate (force out) + + wa <- async $ do + BS.hPutStr w bs + hClose w + + out <- wait ra + wait wa + + assertEqual "createPipe should support Unicode roundtripping" bs out