Fix the killing bug

feedback-test-harness/test/FeedbackSpec.hs

@@ -46,7 +46,7 @@ spec =
         let cp =
               setStdout nullStream
                 . setWorkingDir (fromAbsDir tdir)
-                $ proc "feedback" ["--", "bash", "-c", "'echo hi >" <> fromAbsFile resultFile <> "'"]
+                $ proc "feedback" ["echo hi >" <> fromAbsFile resultFile]
         withProcessKill cp $ \ph -> do
           waitABit
 
@@ -70,7 +70,7 @@ spec =
               setStdout nullStream
                 . setStdin (useHandleOpen slaveHandle)
                 . setWorkingDir (fromAbsDir tdir)
-                $ proc "feedback" ["--", "bash", "-c", "'date +%N >" <> fromAbsFile dateFile <> "'"]
+                $ proc "feedback" ["date +%N >" <> fromAbsFile dateFile]
         withProcessKill cp $ \ph -> do
           waitABit
 
@@ -105,7 +105,7 @@ spec =
               setStdout nullStream
                 . setStdin (useHandleOpen slaveHandle)
                 . setWorkingDir (fromAbsDir tdir)
-                $ proc "feedback" ["--no-clear", "--debug", "--", "bash", "-c", "'date +%N >" <> fromAbsFile dateFile <> "'"]
+                $ proc "feedback" ["--no-clear", "--debug", "--", "date +%N >" <> fromAbsFile dateFile]
         withProcessKill cp $ \ph -> do
           waitABit
 
@@ -164,7 +164,7 @@ spec =
             setStdout nullStream
               . setStdin (useHandleOpen slaveHandle)
               . setWorkingDir (fromAbsDir tdir)
-              $ proc "feedback" ["--no-clear", "--debug", "--", "bash", "-c", "'date +%N >" <> fromAbsFile dateFile <> "'"]
+              $ proc "feedback" ["--no-clear", "--debug", "--", "date +%N >" <> fromAbsFile dateFile]
       withProcessKill cp $ \ph -> do
         waitABit
 

feedback/CHANGELOG.md

@@ -1,5 +1,13 @@
 # Changelog
 
+## [0.1.0.5] - 2024-04-15
+
+### Changed
+
+* Fixed a bug where loops were not killed correctly.
+  Now the loop commands end up in a process group and they are all stopped
+  together.
+
 ## [0.1.0.4] - 2024-01-18
 
 ### Changed
@@ -13,6 +21,7 @@
 
 * Fixed the autocomplete
 
+
 ## [0.1.0.2] - 2023-10-12
 
 ### Added

feedback/default.nix

@@ -1,20 +1,20 @@
 { mkDerivation, autodocodec, autodocodec-yaml, base, bytestring
 , conduit, containers, envparse, fsnotify, lib
-, optparse-applicative, path, path-io, pretty-show
+, optparse-applicative, path, path-io, pretty-show, process
 , safe-coloured-text, safe-coloured-text-layout
 , safe-coloured-text-terminfo, text, time, typed-process, unix
 , unliftio, yaml
 }:
 mkDerivation {
   pname = "feedback";
-  version = "0.1.0.4";
+  version = "0.1.0.5";
   src = ./.;
   isLibrary = true;
   isExecutable = true;
   libraryHaskellDepends = [
     autodocodec autodocodec-yaml base bytestring conduit containers
     envparse fsnotify optparse-applicative path path-io pretty-show
-    safe-coloured-text safe-coloured-text-layout
+    process safe-coloured-text safe-coloured-text-layout
     safe-coloured-text-terminfo text time typed-process unix unliftio
     yaml
   ];

feedback/feedback.cabal

@@ -5,7 +5,7 @@ cabal-version: 2.2
 -- see: https://github.com/sol/hpack
 
 name:           feedback
-version:        0.1.0.4
+version:        0.1.0.5
 synopsis:       Declarative feedback loop manager
 homepage:       https://github.com/NorfairKing/feedback#readme
 bug-reports:    https://github.com/NorfairKing/feedback/issues
@@ -48,6 +48,7 @@ library
     , path
     , path-io
     , pretty-show
+    , process
     , safe-coloured-text
     , safe-coloured-text-layout
     , text

feedback/package.yaml

@@ -1,5 +1,5 @@
 name: feedback
-version: 0.1.0.4
+version: 0.1.0.5
 github: "NorfairKing/feedback"
 license: GPL-3.0-only
 author: "Tom Sydney Kerckhove"
@@ -24,6 +24,7 @@ library:
   - path
   - path-io
   - pretty-show
+  - process
   - safe-coloured-text
   - safe-coloured-text-layout
   - text

feedback/src/Feedback/Common/Process.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# OPTIONS_GHC -fno-warn-unused-pattern-binds #-}
 
@@ -11,6 +12,7 @@ import Path
 import Path.IO
 import System.Environment as System (getEnvironment)
 import System.Exit
+import qualified System.Process as Process
 import System.Process.Typed as Typed
 import UnliftIO.IO.File
 
@@ -40,32 +42,43 @@ makeProcessConfigFor RunSettings {..} = do
   -- Set up the environment
   env <- System.getEnvironment
   let envForProcess = M.toList $ M.union runSettingExtraEnv (M.fromList env)
-  -- Set up the command
-  commandString <- case runSettingCommand of
-    CommandScript s -> do
-      -- Write the script to a file
-      systemTempDir <- getTempDir
-      ensureDir systemTempDir
-      tempDir <- createTempDir systemTempDir "feedback"
-      scriptFile <- resolveFile tempDir "feedback-script.sh"
-      writeBinaryFileDurableAtomic (fromAbsFile scriptFile) (TE.encodeUtf8 (T.pack s))
-      -- Make the script executable
-      oldPermissions <- getPermissions scriptFile
-      let newPermissions = setOwnerExecutable True oldPermissions
-      setPermissions scriptFile newPermissions
+  let CommandScript script = runSettingCommand
+  -- Set up the script file
+  scriptFile <- do
+    -- Write the script to a file
+    systemTempDir <- getTempDir
+    ensureDir systemTempDir
+    tempDir <- createTempDir systemTempDir "feedback"
+    scriptFile <- resolveFile tempDir "feedback-script.sh"
+    writeBinaryFileDurableAtomic (fromAbsFile scriptFile) (TE.encodeUtf8 (T.pack script))
 
-      pure $ fromAbsFile scriptFile
+    -- Make the script executable
+    oldPermissions <- getPermissions scriptFile
+    let newPermissions = setOwnerExecutable True oldPermissions
+    setPermissions scriptFile newPermissions
+
+    pure $ fromAbsFile scriptFile
 
   pure
     $ setStdout inherit
       . setStderr inherit
       . setStdin nullStream -- TODO make this configurable?
       . setEnv envForProcess
+      . setCreateGroup True -- See [ref:ProcessGroup]
       . maybe id (setWorkingDir . fromAbsDir) runSettingWorkingDir
-    $ shell commandString
+    $ shell scriptFile
 
 stopProcessHandle :: ProcessHandle -> IO ()
 stopProcessHandle ProcessHandle {..} = do
+  -- [tag:ProcessGroup]
+  -- We create a new process group for the script we execute.
+  -- The problem this solves is the following:
+  -- When we execute a bash script, and want to stop it by sending a signal to
+  -- it, bash does not propagate this signal to its subprocesses.
+  -- To fix this, we put the bash script in a process group.
+  -- Bash then creates subprocesses in the same process group.
+  -- We can send signals to the entire group at once, which we do here.
+  Process.interruptProcessGroupOf $ unsafeProcessHandle processHandleProcess
   stopProcess processHandleProcess
   -- No need to cancel the waiter thread.
   pure ()

feedback/src/Feedback/Loop.hs

@@ -98,8 +98,7 @@ runFeedbackLoop = do
               eventChan
 
           -- Start the process and put output.
-          worker mainThreadId firstLoop loopSettings terminalCapabilities loopBegin eventChan
-            `finally` stopListeningAction
+          worker mainThreadId firstLoop loopSettings terminalCapabilities loopBegin eventChan stopListeningAction
 
   -- Do the first loop outside the 'forever' so we can run commands before and
   -- after the first loop.
@@ -184,6 +183,7 @@ worker ::
   TerminalCapabilities ->
   ZonedTime ->
   Chan FS.Event ->
+  IO () ->
   IO ()
 worker
   mainThreadId
@@ -191,7 +191,8 @@ worker
   LoopSettings {..}
   terminalCapabilities
   loopBegin
-  eventChan = do
+  eventChan
+  stopListeningAction = do
     let sendOutput :: Output -> IO ()
         sendOutput = putOutput loopSettingOutputSettings terminalCapabilities loopBegin
 
@@ -226,6 +227,10 @@ worker
     let handleEventHappened event = do
           -- Output the event that has fired
           sendOutput $ OutputEvent event
+          -- Output that we'll stop watching now
+          sendOutput OutputStopWatching
+          -- Stop watching
+          stopListeningAction
           -- Output that killing will start
           sendOutput OutputKilling
           -- Kill the process
@@ -250,6 +255,10 @@ worker
           -- Output the event that made the rerun happen
           event <- waitForEvent eventChan
           sendOutput $ OutputEvent event
+          -- Output that we'll stop watching now
+          sendOutput OutputStopWatching
+          -- Stop watching
+          stopListeningAction
 
     -- Either wait for it to finish or wait for an event
     eventOrDone <-
@@ -293,6 +302,7 @@ waitForEvent eventChan = do
 data Output
   = OutputFiltering
   | OutputWatching
+  | OutputStopWatching
   | OutputEvent !RestartEvent
   | OutputKilling
   | OutputKilled
@@ -306,6 +316,7 @@ putOutput OutputSettings {..} terminalCapabilities loopBegin =
    in \case
         OutputFiltering -> put [indicatorChunk "filtering"]
         OutputWatching -> put [indicatorChunk "watching"]
+        OutputStopWatching -> put [indicatorChunk "stop watching"]
         OutputEvent restartEvent -> do
           put $
             indicatorChunk "event:"

flake.nix

@@ -71,6 +71,7 @@
             nixpkgs-fmt.enable = true;
             nixpkgs-fmt.excludes = [ ".*/default.nix" ];
             cabal2nix.enable = true;
+            tagref.enable = true;
           };
         };
       };
@@ -91,6 +92,7 @@
             nixpkgs-fmt
             ormolu
             cabal2nix
+            tagref
           ]);
         shellHook = self.checks.${system}.pre-commit.shellHook + pkgs.feedback.shellHook;
       };

nix/overlay.nix

@@ -46,6 +46,9 @@ with final.haskell.lib;
             buildDepends = (old.buildDepends or [ ]) ++ [
               final.git
             ];
+            testToolDepends = (old.testToolDepends or [ ]) ++ [
+              final.feedback
+            ];
             # Ugly hack because we can't just add flags to the 'test' invocation.
             # Show test output as we go, instead of all at once afterwards.
             testTarget = (old.testTarget or "") + " --show-details=direct --test-options=--debug";