From bceac781e4505a6e2089621012deee449fe62b11 Mon Sep 17 00:00:00 2001
From: Ben Sima <ben@bsima.me>
Date: Mon, 15 Apr 2024 15:32:22 -0400
Subject: Cleanup build processes on timeout

On timeout, bild would leave it's child processes still running, which means
that a long build would continue to go in the background, and I'd have to
manually find and kill it. The fix was simply to use Conduit's
`closeStreamingProcessHandle` function, and make sure that Conduit created a
group for the processes (by default it doesn't).

I tested this by building and running `bild` with a very low timeout (1 minute)
and watching `gotop` to make sure it stopped the active build process. I
couldn't figure out a simple way to test this automatically.
---
 Biz/Bild.hs | 22 ++++++++++++++--------
 1 file changed, 14 insertions(+), 8 deletions(-)

(limited to 'Biz')

diff --git a/Biz/Bild.hs b/Biz/Bild.hs
index f8385c8..cc10782 100644
--- a/Biz/Bild.hs
+++ b/Biz/Bild.hs
@@ -208,16 +208,14 @@ move args =
         /> filter isBuildableNs
         +> foldM analyze mempty
         +> printOrBuild
-        +> exitSummary
-        -- convert minutes to microseconds
-        |> Timeout.timeout (minutes * 60_000_000)
+        |> Timeout.timeout (toMillis minutes)
         +> \case
           Nothing ->
-            Log.wipe
+            Log.br
               >> Log.fail ["bild", "timeout after " <> tshow minutes <> " minutes"]
+              >> Log.br
               >> exitWith (ExitFailure 124)
-          Just _ ->
-            pure ()
+          Just s -> exitSummary s
   where
     minutes =
       Cli.getArgWithDefault args "10" (Cli.longOption "time")
@@ -951,12 +949,17 @@ data Proc = Proc
     onSuccess :: IO ()
   }
 
+-- | Convert minutes to milliseconds.
+toMillis :: Num a => a -> a
+toMillis mins = mins * 60_000_000
+
 -- | Run a subprocess, streaming output if --loud is set.
 run :: Proc -> IO (Exit.ExitCode, ByteString)
 run Proc {..} = do
   IO.hSetBuffering stdout IO.NoBuffering
   loud ?| Log.info ["proc", unwords <| map str <| cmd : args]
   Conduit.proc cmd args
+    |> (\proc -> proc {Process.create_group = True})
     |> Conduit.streamingProcess
     +> \(Conduit.UseProvidedHandle, stdout_, stderr_, hdl) ->
       (,,) </ Async.Concurrently (Conduit.waitForStreamingProcess hdl)
@@ -965,11 +968,14 @@ run Proc {..} = do
           |> Async.runConcurrently
           +> \case
             (Exit.ExitFailure n, output, outerr) ->
-              putStr outerr
+              Conduit.closeStreamingProcessHandle hdl
+                >> putStr outerr
                 >> onFailure
                 >> pure (Exit.ExitFailure n, output)
             (Exit.ExitSuccess, output, _) ->
-              onSuccess >> pure (Exit.ExitSuccess, output)
+              Conduit.closeStreamingProcessHandle hdl
+                >> onSuccess
+                >> pure (Exit.ExitSuccess, output)
 
 -- | Helper for running a standard bild subprocess.
 proc ::
-- 
cgit v1.2.3