Refactor build code to use process utilities

Initially, this was in preparation for a resolution to #1635. However, I
I don't think I'll be using the approach of sending stderr / stdout via
logging. Some tests could emit tons of output, and I'd rather avoid the
overhead.

Author: mgsloan

src/Stack/Build/Execute.hs

@@ -842,63 +842,39 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
                            ++ ["-package-db=" ++ toFilePathNoTrailingSep (bcoSnapDB eeBaseConfigOpts)]
 
                 setupArgs = ("--builddir=" ++ toFilePathNoTrailingSep distRelativeDir') : args
-                runExe exeName fullArgs = do
-                    $logProcessRun (toFilePath exeName) fullArgs
-
-                    -- Use createProcess_ to avoid the log file being closed afterwards
-                    (Nothing, moutH, merrH, ph) <- liftIO $ createProcess_ "singleBuild" cp
-
-                    let makeAbsolute = stripTHLoading -- If users want control, we should add a config option for this
-
-                    ec <-
-                        liftIO $
-                        withAsync (runInBase $ maybePrintBuildOutput stripTHLoading makeAbsolute pkgDir LevelInfo mlogFile moutH) $ \outThreadID ->
-                        withAsync (runInBase $ maybePrintBuildOutput False makeAbsolute pkgDir LevelWarn mlogFile merrH) $ \errThreadID -> do
-                            ec <- waitForProcess ph
-                            wait errThreadID
-                            wait outThreadID
-                            return ec
-                    case ec of
-                        ExitSuccess -> return ()
-                        _ -> do
-                            bss <-
-                                case mlogFile of
-                                    Nothing -> return []
-                                    Just (logFile, h) -> do
-                                        liftIO $ hClose h
-                                        runResourceT
-                                            $ CB.sourceFile (toFilePath logFile)
-                                            =$= CT.decodeUtf8
-                                            $$ mungeBuildOutput stripTHLoading makeAbsolute pkgDir
-                                            =$ CL.consume
-                            throwM $ CabalExitedUnsuccessfully
-                                ec
-                                taskProvides
-                                exeName
-                                fullArgs
-                                (fmap fst mlogFile)
-                                bss
-                  where
-                    cp0 = proc (toFilePath exeName) fullArgs
-                    cp = cp0
-                        { cwd = Just $ toFilePath pkgDir
-                        , Process.env = envHelper menv
-                        -- Ideally we'd create a new pipe here and then close it
-                        -- below to avoid the child process from taking from our
-                        -- stdin. However, if we do this, the child process won't
-                        -- be able to get the codepage on Windows that we want.
-                        -- See:
-                        -- https://github.com/commercialhaskell/stack/issues/738
-                        -- , std_in = CreatePipe
-                        , std_out =
-                            case mlogFile of
-                                    Nothing -> CreatePipe
-                                    Just (_, h) -> UseHandle h
-                        , std_err =
+                runExe exeName fullArgs =
+                    runAndOutput `catch` \(ProcessExitedUnsuccessfully _ ec) -> do
+                        bss <-
                             case mlogFile of
-                                Nothing -> CreatePipe
-                                Just (_, h) -> UseHandle h
-                        }
+                                Nothing -> return []
+                                Just (logFile, h) -> do
+                                    liftIO $ hClose h
+                                    runResourceT
+                                        $ CB.sourceFile (toFilePath logFile)
+                                        =$= CT.decodeUtf8
+                                        $$ mungeBuildOutput stripTHLoading makeAbsolute pkgDir
+                                        =$ CL.consume
+                        throwM $ CabalExitedUnsuccessfully
+                            ec
+                            taskProvides
+                            exeName
+                            fullArgs
+                            (fmap fst mlogFile)
+                            bss
+                  where
+                    runAndOutput = case mlogFile of
+                        Just (_, h) ->
+                            sinkProcessStderrStdoutHandle (Just pkgDir) menv (toFilePath exeName) fullArgs h h
+                        Nothing ->
+                            void $ sinkProcessStderrStdout (Just pkgDir) menv (toFilePath exeName) fullArgs
+                                (outputSink False LevelWarn)
+                                (outputSink stripTHLoading LevelInfo)
+                    outputSink excludeTH level =
+                        CT.decodeUtf8
+                        =$ mungeBuildOutput excludeTH makeAbsolute pkgDir
+                        =$ CL.mapM_ (runInBase . monadLoggerLog $(TH.location >>= liftLoc) "" level)
+                    -- If users want control, we should add a config option for this
+                    makeAbsolute = stripTHLoading
 
             wc <- getWhichCompiler
             (exeName, fullArgs) <- case (esetupexehs, wc) of
@@ -927,14 +903,6 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
                     return (outputFile, setupArgs)
             runExe exeName $ (if boptsCabalVerbose eeBuildOpts then ("--verbose":) else id) fullArgs
 
-    maybePrintBuildOutput stripTHLoading makeAbsolute pkgDir level mlogFile mh =
-        case mh of
-            Just h ->
-                case mlogFile of
-                  Just{} -> return ()
-                  Nothing -> printBuildOutput stripTHLoading makeAbsolute pkgDir level h
-            Nothing -> return ()
-
 singleBuild :: M env m
             => (m () -> IO ())
             -> ActionContext
@@ -1356,23 +1324,6 @@ singleBench runInBase beopts benchesToRun ac ee task installedMap = do
           announce "benchmarks"
           cabal False ("bench" : args)
 
--- | Grab all output from the given @Handle@ and log it, stripping
--- Template Haskell "Loading package" lines and making paths absolute.
--- thread.
-printBuildOutput :: (MonadIO m, MonadBaseControl IO m, MonadLogger m,
-                     MonadThrow m)
-                 => Bool -- ^ exclude TH loading?
-                 -> Bool -- ^ convert paths to absolute?
-                 -> Path Abs Dir -- ^ package's root directory
-                 -> LogLevel
-                 -> Handle
-                 -> m ()
-printBuildOutput excludeTHLoading makeAbsolute pkgDir level outH = void $
-    CB.sourceHandle outH
-    $$ CT.decodeUtf8
-    =$ mungeBuildOutput excludeTHLoading makeAbsolute pkgDir
-    =$ CL.mapM_ (monadLoggerLog $(TH.location >>= liftLoc) "" level)
-
 -- | Strip Template Haskell "Loading package" lines and making paths absolute.
 mungeBuildOutput :: (MonadIO m, MonadThrow m)
                  => Bool -- ^ exclude TH loading?

src/System/Process/Read.hs

@@ -14,6 +14,7 @@ module System.Process.Read
   ,tryProcessStdout
   ,sinkProcessStdout
   ,sinkProcessStderrStdout
+  ,sinkProcessStderrStdoutHandle
   ,readProcess
   ,EnvOverride(..)
   ,unEnvOverride
@@ -34,9 +35,8 @@ module System.Process.Read
   )
   where
 
-import           Control.Applicative
 import           Control.Arrow ((***), first)
-import           Control.Concurrent.Async (Concurrently (..))
+import           Control.Concurrent.Async (concurrently)
 import           Control.Exception hiding (try, catch)
 import           Control.Monad (join, liftM, unless)
 import           Control.Monad.Catch (MonadThrow, MonadCatch, throwM, try, catch)
@@ -69,6 +69,7 @@ import           System.Directory (doesFileExist, getCurrentDirectory)
 import           System.Environment (getEnvironment)
 import           System.Exit
 import qualified System.FilePath as FP
+import           System.IO (Handle)
 import           System.Process.Log
 
 -- | Override the environment received by a child process.
@@ -256,7 +257,7 @@ sinkProcessStdout wd menv name args sinkStdout = do
   return sinkRet
 
 -- | Consume the stdout and stderr of a process feeding strict 'S.ByteString's to the consumers.
-sinkProcessStderrStdout :: (MonadIO m, MonadLogger m)
+sinkProcessStderrStdout :: forall m e o. (MonadIO m, MonadLogger m)
                         => Maybe (Path Abs Dir) -- ^ Optional directory to run in
                         -> EnvOverride
                         -> String -- ^ Command
@@ -267,15 +268,32 @@ sinkProcessStderrStdout :: (MonadIO m, MonadLogger m)
 sinkProcessStderrStdout wd menv name args sinkStderr sinkStdout = do
   $logProcessRun name args
   name' <- preProcess wd menv name
-  liftIO (withCheckedProcess
-            (proc name' args) { env = envHelper menv, cwd = fmap toFilePath wd }
-            (\ClosedStream out err ->
-               runConcurrently $
-               (,) <$>
-               Concurrently (asBSSource err $$ sinkStderr) <*>
-               Concurrently (asBSSource out $$ sinkStdout)))
-  where asBSSource :: Source m S.ByteString -> Source m S.ByteString
-        asBSSource = id
+  liftIO $ withCheckedProcess
+      (proc name' args) { env = envHelper menv, cwd = fmap toFilePath wd }
+      (\ClosedStream out err -> f err out)
+  where
+    f :: Source IO S.ByteString -> Source IO S.ByteString -> IO (e, o)
+    f err out = (err $$ sinkStderr) `concurrently` (out $$ sinkStdout)
+
+sinkProcessStderrStdoutHandle :: (MonadIO m, MonadLogger m)
+                              => Maybe (Path Abs Dir) -- ^ Optional directory to run in
+                              -> EnvOverride
+                              -> String -- ^ Command
+                              -> [String] -- ^ Command line arguments
+                              -> Handle
+                              -> Handle
+                              -> m ()
+sinkProcessStderrStdoutHandle wd menv name args err out = do
+  $logProcessRun name args
+  name' <- preProcess wd menv name
+  liftIO $ withCheckedProcess
+      (proc name' args)
+          { env = envHelper menv
+          , cwd = fmap toFilePath wd
+          , std_err = UseHandle err
+          , std_out = UseHandle out
+          }
+      (\ClosedStream UseProvidedHandle UseProvidedHandle -> return ())
 
 -- | Perform pre-call-process tasks.  Ensure the working directory exists and find the
 -- executable path.