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(-)
(limited to 'Biz/Bild.hs')
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