feedback 0.1.0.4 → 0.1.0.5

raw patch · 3 files changed

+45/−20 lines, 3 filesdep +process

Dependencies added: process

Files

• feedback.cabal +3/−2
• src/Feedback/Common/Process.hs +28/−15
• src/Feedback/Loop.hs +14/−3

@@ -1,11 +1,11 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.35.2.+-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- 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 @@     , path     , path-io     , pretty-show+    , process     , safe-coloured-text     , safe-coloured-text-layout     , text

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-unused-pattern-binds #-} @@ -11,6 +12,7 @@ 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 @@   -- 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 ()

@@ -98,8 +98,7 @@               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 @@   TerminalCapabilities ->   ZonedTime ->   Chan FS.Event ->+  IO () ->   IO () worker   mainThreadId@@ -191,7 +191,8 @@   LoopSettings {..}   terminalCapabilities   loopBegin-  eventChan = do+  eventChan+  stopListeningAction = do     let sendOutput :: Output -> IO ()         sendOutput = putOutput loopSettingOutputSettings terminalCapabilities loopBegin @@ -226,6 +227,10 @@     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 @@           -- 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 @@ data Output   = OutputFiltering   | OutputWatching+  | OutputStopWatching   | OutputEvent !RestartEvent   | OutputKilling   | OutputKilled@@ -306,6 +316,7 @@    in \case         OutputFiltering -> put [indicatorChunk "filtering"]         OutputWatching -> put [indicatorChunk "watching"]+        OutputStopWatching -> put [indicatorChunk "stop watching"]         OutputEvent restartEvent -> do           put $             indicatorChunk "event:"