From 8b61b194f2f4759689844ab57f2ca7a4b912c468 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sat, 4 Apr 2026 16:29:55 +0200 Subject: Add pid member to the Process type Changelog: Added `pid` member to the `Process` type to get its system PID --- README.md | 3 +++ src/GDB.hs | 2 ++ src/Process.hs | 10 ++++++---- src/Script/Shell.hs | 1 + 4 files changed, 12 insertions(+), 4 deletions(-) diff --git a/README.md b/README.md index d1d12bb..3e874a4 100644 --- a/README.md +++ b/README.md @@ -210,6 +210,9 @@ Members: `node` : Node on which the process is running. +`pid` +: PID of the corresponding system process, `0` if there is none. + #### asset Represents an asset (file or directory), which can be used during test execution. diff --git a/src/GDB.hs b/src/GDB.hs index ccb9dc3..4151946 100644 --- a/src/GDB.hs +++ b/src/GDB.hs @@ -73,6 +73,7 @@ gdbStart onCrash = do } pout <- liftIO $ newTVarIO [] ignore <- liftIO $ newTVarIO ( 0, [] ) + pid <- liftIO $ getPid handle let process = Process { procId = ProcessId (-2) @@ -83,6 +84,7 @@ gdbStart onCrash = do , procIgnore = ignore , procKillWith = Nothing , procNode = undefined + , procPid = pid } gdb <- GDB <$> pure process diff --git a/src/Process.hs b/src/Process.hs index e04bfe7..d4ee68b 100644 --- a/src/Process.hs +++ b/src/Process.hs @@ -58,6 +58,7 @@ data Process = Process , procIgnore :: TVar ( Int, [ ( Int, Maybe Regex ) ] ) , procKillWith :: Maybe Signal , procNode :: Node + , procPid :: Maybe Pid } instance Eq Process where @@ -68,7 +69,8 @@ instance ExprType Process where textExprValue p = " textProcName (procName p) <> "#" <> textProcId (procId p) <> ">" recordMembers = map (first T.pack) - [ ("node", RecordSelector $ procNode) + [ ( "node", RecordSelector $ procNode ) + , ( "pid", RecordSelector $ maybe (0 :: Integer) fromIntegral . procPid ) ] @@ -169,6 +171,7 @@ spawnOn target procName procKillWith cmd = do procOutput <- liftIO $ newTVarIO [] procIgnore <- liftIO $ newTVarIO ( 0, [] ) let procNode = either (const undefined) id target + procPid <- liftIO $ getPid handle let process = Process {..} startProcessIOLoops process hout herr @@ -182,10 +185,9 @@ spawnOn target procName procKillWith cmd = do closeProcess :: (MonadIO m, MonadOutput m, MonadError Failed m) => Scientific -> Process -> m () closeProcess timeout p = do liftIO $ hClose $ procStdin p - mbPid <- liftIO $ either getPid (\_ -> return Nothing) (procHandle p) case procKillWith p of Nothing -> return () - Just sig -> case mbPid of + Just sig -> case procPid p of Nothing -> return () Just pid -> liftIO $ signalProcess sig pid @@ -193,7 +195,7 @@ closeProcess timeout p = do threadDelay $ floor $ 1000000 * timeout either terminateProcess (killThread . fst) $ procHandle p - status <- case mbPid of + status <- case procPid p of Nothing -> Just . Exited <$> liftIO (either waitForProcess (takeMVar . snd) (procHandle p)) Just pid -> liftIO (getProcessStatus True False pid) case status of diff --git a/src/Script/Shell.hs b/src/Script/Shell.hs index dea3fe9..2d1b82b 100644 --- a/src/Script/Shell.hs +++ b/src/Script/Shell.hs @@ -202,6 +202,7 @@ spawnShell procNode procName script = do hClose pstderr let procKillWith = Nothing + let procPid = Nothing let process = Process {..} startProcessIOLoops process hout herr -- cgit v1.2.3