xmonad-config/lib/XMonad/Internal/Process.hs

97 lines
3.1 KiB
Haskell
Raw Normal View History

2020-04-01 22:06:00 -04:00
--------------------------------------------------------------------------------
-- | Functions for managing processes
2020-04-01 20:17:47 -04:00
module XMonad.Internal.Process
( waitUntilExit
, killHandle
2022-07-03 01:11:32 -04:00
, spawnPipe'
, spawnPipe
2022-07-03 01:11:32 -04:00
, spawnPipeArgs
, createProcess'
, readCreateProcessWithExitCode'
, proc'
, shell'
, spawn
, spawnAt
, module System.Process
2020-04-01 20:17:47 -04:00
) where
import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Data.Maybe
2022-12-26 15:18:50 -05:00
import qualified RIO.Text as T
import System.Directory
import System.Exit
import System.IO
import System.Posix.Signals
import System.Process
import XMonad.Core hiding (spawn)
-- | Block until a PID has exited (in any form)
-- ASSUMPTION on linux PIDs will always increase until they overflow, in which
-- case they will start to recycle. Barring any fork bombs, this code should
-- work because we can reasonably expect that no processes will spawn with the
-- same PID within the delay limit
-- TODO this will not work if the process is a zombie (maybe I care...)
waitUntilExit :: Show t => t -> IO ()
waitUntilExit pid = do
res <- doesDirectoryExist $ "/proc/" ++ show pid
when res $ threadDelay 100000 >> waitUntilExit pid
killHandle :: ProcessHandle -> IO ()
killHandle ph = do
ec <- getProcessExitCode ph
unless (isJust ec) $ do
pid <- getPid ph
forM_ pid $ signalProcess sigTERM
-- this may fail if the process exits instantly and the handle
-- is destroyed by the time we get to this line (I think?)
void (try $ waitForProcess ph :: IO (Either IOException ExitCode))
withDefaultSignalHandlers :: IO a -> IO a
withDefaultSignalHandlers =
bracket_ uninstallSignalHandlers installSignalHandlers
addGroupSession :: CreateProcess -> CreateProcess
addGroupSession cp = cp { create_group = True, new_session = True }
createProcess' :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess' = withDefaultSignalHandlers . createProcess
2022-12-26 15:18:50 -05:00
readCreateProcessWithExitCode' :: CreateProcess -> String
-> IO (ExitCode, T.Text, T.Text)
readCreateProcessWithExitCode' c i = withDefaultSignalHandlers $ do
(r, e, p) <- readCreateProcessWithExitCode c i
return (r, T.pack e, T.pack p)
shell' :: String -> CreateProcess
shell' = addGroupSession . shell
proc' :: FilePath -> [String] -> CreateProcess
proc' cmd args = addGroupSession $ proc cmd args
spawn :: MonadIO m => String -> m ()
spawn = io . void . createProcess' . shell'
spawnAt :: MonadIO m => FilePath -> String -> m ()
spawnAt fp cmd = io $ void $ createProcess' $ (shell' cmd) { cwd = Just fp }
2022-07-03 01:11:32 -04:00
spawnPipe' :: CreateProcess -> IO (Handle, ProcessHandle)
spawnPipe' cp = do
-- ASSUME creating a pipe will always succeed in making a Just Handle
2022-07-03 01:11:32 -04:00
(Just h, _, _, p) <- createProcess' $ cp { std_in = CreatePipe }
hSetBuffering h LineBuffering
return (h, p)
2022-07-03 01:11:32 -04:00
spawnPipe :: String -> IO (Handle, ProcessHandle)
spawnPipe = spawnPipe' . shell
spawnPipeArgs :: FilePath -> [String] -> IO (Handle, ProcessHandle)
spawnPipeArgs cmd = spawnPipe' . proc cmd