From 90b15b0ecc6fc153120e0d01288697dfe10e28f9 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Mon, 26 Sep 2022 22:17:52 +0200
Subject: Process lifetime determined by scope

---
 src/Process.hs | 29 ++++++++++++++++++++++++++++-
 1 file changed, 28 insertions(+), 1 deletion(-)

(limited to 'src/Process.hs')

diff --git a/src/Process.hs b/src/Process.hs
index 958910d..bb33953 100644
--- a/src/Process.hs
+++ b/src/Process.hs
@@ -3,19 +3,25 @@ module Process (
     ProcName(..),
     textProcName, unpackProcName,
     send,
+    outProc,
+    closeProcess,
 ) where
 
 import Control.Concurrent.STM
-import Control.Monad.IO.Class
+import Control.Monad.Except
 
+import Data.Function
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 
+import System.Exit
 import System.IO
 import System.Posix.Signals
 import System.Process
 
+import Output
+
 data Process = Process
     { procName :: ProcName
     , procHandle :: ProcessHandle
@@ -24,6 +30,9 @@ data Process = Process
     , procKillWith :: Maybe Signal
     }
 
+instance Eq Process where
+    (==) = (==) `on` procStdin
+
 data ProcName = ProcName Text
               | ProcNameTcpdump
               | ProcNameGDB
@@ -41,3 +50,21 @@ send :: MonadIO m => Process -> Text -> m ()
 send p line = liftIO $ do
     T.hPutStrLn (procStdin p) line
     hFlush (procStdin p)
+
+outProc :: MonadOutput m => OutputType -> Process -> Text -> m ()
+outProc otype p line = outLine otype (textProcName $ procName p) line
+
+closeProcess :: (MonadIO m, MonadOutput m, MonadError () m) => Process -> m ()
+closeProcess p = do
+    liftIO $ hClose $ procStdin p
+    case procKillWith p of
+        Nothing -> return ()
+        Just sig -> liftIO $ getPid (procHandle p) >>= \case
+            Nothing -> return ()
+            Just pid -> signalProcess sig pid
+
+    liftIO (waitForProcess (procHandle p)) >>= \case
+        ExitSuccess -> return ()
+        ExitFailure code -> do
+            outProc OutputChildFail p $ T.pack $ "exit code: " ++ show code
+            throwError ()
-- 
cgit v1.2.3