From 1f2a9f1a331ebd64589da5e41692851ab47cf456 Mon Sep 17 00:00:00 2001
From: Ben Sima <ben@bsima.me>
Date: Mon, 31 Jul 2023 13:58:50 -0400
Subject: Capture and return stdout from proc

---
 Biz/Bild.hs | 72 ++++++++++++++++++++++++++++++++++---------------------------
 1 file changed, 40 insertions(+), 32 deletions(-)

diff --git a/Biz/Bild.hs b/Biz/Bild.hs
index 562f43a..0747cf5 100644
--- a/Biz/Bild.hs
+++ b/Biz/Bild.hs
@@ -657,7 +657,7 @@ isSuccess :: Exit.ExitCode -> Bool
 isSuccess Exit.ExitSuccess = True
 isSuccess _ = False
 
-test :: Bool -> Target -> IO Exit.ExitCode
+test :: Bool -> Target -> IO (Exit.ExitCode, ByteString)
 test loud Target {..} = case compiler of
   Ghc -> do
     root <- Env.getEnv "BIZ_ROOT"
@@ -673,13 +673,13 @@ test loud Target {..} = case compiler of
   _ ->
     Log.warn ["test", nschunk namespace, "unavailable"]
       >> Log.br
-      >> pure (Exit.ExitFailure 1)
+      >> pure (Exit.ExitFailure 1, mempty)
 
 build :: Bool -> Bool -> Analysis -> IO [Exit.ExitCode]
 build andTest loud analysis =
   Env.getEnv "BIZ_ROOT" +> \root ->
-    forM (Map.elems analysis) <| \target@Target {..} -> do
-      case compiler of
+    forM (Map.elems analysis) <| \target@Target {..} ->
+      fst </ case compiler of
         Gcc ->
           Log.info ["bild", label, "gcc", nschunk namespace]
             >> proc loud namespace (toNixFlag compiler) compilerFlags
@@ -688,13 +688,13 @@ build andTest loud analysis =
               Meta.Bin _ -> "bin"
               _ -> "lib"
         Ghc -> case out of
-          Meta.None -> pure Exit.ExitSuccess
+          Meta.None -> pure (Exit.ExitSuccess, mempty)
           Meta.Bin _ -> do
             Log.info ["bild", "dev", "ghc-exe", nschunk namespace]
-            exitcode <- proc loud namespace (toNixFlag compiler) compilerFlags
-            if andTest && isSuccess exitcode
+            result <- proc loud namespace (toNixFlag compiler) compilerFlags
+            if andTest && (isSuccess <| fst result)
               then test loud target
-              else pure exitcode
+              else pure result
           Meta.Lib _ -> do
             Log.info ["bild", "dev", "ghc-lib", nschunk namespace]
             proc loud namespace (toNixFlag compiler) compilerFlags
@@ -702,12 +702,12 @@ build andTest loud analysis =
           Log.info ["bild", "dev", "guile", nschunk namespace]
           _ <- proc loud namespace (toNixFlag compiler) compilerFlags
           case wrapper of
-            Nothing -> pure Exit.ExitSuccess
+            Nothing -> pure (Exit.ExitSuccess, mempty)
             Just content -> do
               writeFile (root </> outToPath out) content
               p <- Dir.getPermissions <| root </> outToPath out
               Dir.setPermissions (root </> outToPath out) (Dir.setOwnerExecutable True p)
-              pure Exit.ExitSuccess
+              pure (Exit.ExitSuccess, mempty)
         NixBuild -> do
           Log.info ["bild", "nix", toLog builder, nschunk namespace]
           proc loud namespace (toNixFlag compiler) compilerFlags
@@ -716,7 +716,7 @@ build andTest loud analysis =
             toLog (Remote u h) = u <> "@" <> h
         Copy -> do
           Log.warn ["bild", "copy", "not implemented yet", nschunk namespace]
-          pure Exit.ExitSuccess
+          pure (Exit.ExitSuccess, mempty)
         Rustc -> do
           Log.info ["bild", "dev", "rust", nschunk namespace]
           proc loud namespace (toNixFlag compiler) compilerFlags
@@ -734,32 +734,40 @@ data Proc = Proc
   }
 
 -- | Run a subprocess, streaming output if --loud is set.
-run :: Proc -> IO Exit.ExitCode
+run :: Proc -> IO (Exit.ExitCode, ByteString)
 run Proc {..} =
-  Conduit.proc cmd args |> Conduit.streamingProcess
+  Conduit.proc cmd args
+    |> Conduit.streamingProcess
     +> \(Conduit.UseProvidedHandle, stdout_, stderr_, hdl) ->
-      Async.Concurrently (loud ?: (puts stdout_, logs ns stdout_))
-        *> Async.Concurrently (loud ?: (puts stderr_, logs ns stderr_))
-        *> Async.Concurrently (putsToTmp stdout_ "/tmp/bild-log.out")
-        *> Async.Concurrently (putsToTmp stderr_ "/tmp/bild-log.err")
-        *> Async.Concurrently (Conduit.waitForStreamingProcess hdl)
-        |> Async.runConcurrently
-        +> \case
-          Exit.ExitFailure n -> puts stderr_ >> onFailure >> pure (Exit.ExitFailure n)
-          Exit.ExitSuccess -> onSuccess >> pure Exit.ExitSuccess
+      Conduit.runConduitRes (stdout_ .| Conduit.foldC)
+        +> \output ->
+          Async.Concurrently (loud ?: (puts stdout_, logs ns stdout_))
+            *> Async.Concurrently (loud ?: (puts stderr_, logs ns stderr_))
+            *> Async.Concurrently (putsToTmp stdout_ "/tmp/bild-log.out")
+            *> Async.Concurrently (putsToTmp stderr_ "/tmp/bild-log.err")
+            *> Async.Concurrently (Conduit.waitForStreamingProcess hdl)
+            |> Async.runConcurrently
+            +> \case
+              Exit.ExitFailure n ->
+                puts stderr_
+                  >> onFailure
+                  >> pure (Exit.ExitFailure n, output)
+              Exit.ExitSuccess ->
+                onSuccess
+                  >> pure (Exit.ExitSuccess, output)
 
 -- | Helper for running a standard bild subprocess.
-proc :: Bool -> Namespace -> String -> [Text] -> IO Exit.ExitCode
+proc :: Bool -> Namespace -> String -> [Text] -> IO (Exit.ExitCode, ByteString)
 proc loud namespace cmd args =
-  run
-    <| Proc
-      { loud = loud,
-        ns = namespace,
-        cmd = cmd,
-        args = map Text.unpack args,
-        onFailure = Log.fail ["bild", nschunk namespace] >> Log.br,
-        onSuccess = Log.good ["bild", nschunk namespace] >> Log.br
-      }
+  Proc
+    { loud = loud,
+      ns = namespace,
+      cmd = cmd,
+      args = map Text.unpack args,
+      onFailure = Log.fail ["bild", nschunk namespace] >> Log.br,
+      onSuccess = Log.good ["bild", nschunk namespace] >> Log.br
+    }
+    |> run
 
 -- | Helper for printing during a subprocess
 puts :: Conduit.ConduitT () ByteString (Conduit.ResourceT IO) () -> IO ()
-- 
cgit v1.2.3