diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/GDB.hs | 2 | ||||
| -rw-r--r-- | src/Process.hs | 10 | ||||
| -rw-r--r-- | src/Script/Shell.hs | 1 |
3 files changed, 9 insertions, 4 deletions
@@ -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 = "<process:" <> 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 |