Merge pull request #6865 from phadej/create-pipe

phadej · web-flow · commit dde6255a4e6b · 2020-06-02T12:22:56.000+03:00
Use process createPipe
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
