ENH use process package instead of unix for spawning subshells

This commit is contained in:
Nathan Dwarshuis 2020-04-06 00:14:56 -04:00
parent d4cdd69b80
commit 9b3f69bb11
6 changed files with 67 additions and 59 deletions

View File

@ -61,7 +61,7 @@ import XMonad.Util.NamedActions
main :: IO () main :: IO ()
main = do main = do
cl <- startXMonadService cl <- startXMonadService
(p, h) <- spawnPipe' "xmobar" (h, p) <- spawnPipe "xmobar"
_ <- forkIO runPowermon _ <- forkIO runPowermon
_ <- forkIO $ runWorkspaceMon allDWs _ <- forkIO $ runWorkspaceMon allDWs
let ts = ThreadState let ts = ThreadState
@ -91,14 +91,14 @@ main = do
data ThreadState = ThreadState data ThreadState = ThreadState
{ client :: Client { client :: Client
, childPIDs :: [Pid] , childPIDs :: [ProcessHandle]
, childHandles :: [Handle] , childHandles :: [Handle]
} }
-- TODO shouldn't this be run by a signal handler? -- TODO shouldn't this be run by a signal handler?
runCleanup :: ThreadState -> X () runCleanup :: ThreadState -> X ()
runCleanup ts = io $ do runCleanup ts = io $ do
mapM_ killPID $ childPIDs ts mapM_ killHandle $ childPIDs ts
stopXMonadService $ client ts stopXMonadService $ client ts
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -229,6 +229,7 @@ data HIDE = HIDE
instance Transformer HIDE Window where instance Transformer HIDE Window where
transform _ x k = k EmptyLayout (\EmptyLayout -> x) transform _ x k = k EmptyLayout (\EmptyLayout -> x)
-- TODO toggle back to normal when a new window is opened
runHide :: X () runHide :: X ()
runHide = sendMessage $ Toggle HIDE runHide = sendMessage $ Toggle HIDE

View File

@ -22,11 +22,11 @@ import Graphics.X11.Xrandr
import System.IO import System.IO
import XMonad.Core import XMonad.Core hiding (spawn)
import XMonad.Internal.Process
import XMonad.Internal.Shell import XMonad.Internal.Shell
import XMonad.StackSet import XMonad.StackSet
import XMonad.Util.NamedActions import XMonad.Util.NamedActions
import XMonad.Util.Run
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Fix rofi screen indexing limitations -- | Fix rofi screen indexing limitations
@ -96,11 +96,9 @@ runShowKeys x = addName "Show Keybindings" $ do
name <- getMonitorName name <- getMonitorName
case name of case name of
Just n -> do Just n -> do
h <- spawnPipe $ cmd n (h, _, _, _) <- io $ createProcess' $ (shell' $ cmd n)
io $ hPutStr h (unlines $ showKm x) { std_in = CreatePipe }
io $ hClose h io $ forM_ h $ \h' -> hPutStr h' (unlines $ showKm x) >> hClose h'
return ()
-- TODO put better error message here
Nothing -> io $ putStrLn "fail" Nothing -> io $ putStrLn "fail"
where cmd name = fmtCmd myDmenuCmd where cmd name = fmtCmd myDmenuCmd
[ "-dmenu" [ "-dmenu"

View File

@ -33,10 +33,11 @@ import Control.Monad (void)
import System.Directory (getHomeDirectory) import System.Directory (getHomeDirectory)
import XMonad.Actions.Volume import XMonad.Actions.Volume
import XMonad.Core import XMonad.Core hiding (spawn)
import XMonad.Internal.DBus.IntelBacklight import XMonad.Internal.DBus.IntelBacklight
import XMonad.Internal.DBus.Screensaver import XMonad.Internal.DBus.Screensaver
import XMonad.Internal.Notify import XMonad.Internal.Notify
import XMonad.Internal.Process
import XMonad.Internal.Shell import XMonad.Internal.Shell
import XMonad.Operations import XMonad.Operations
@ -124,14 +125,17 @@ runRestart = restart "xmonad" True
runRecompile :: X () runRecompile :: X ()
runRecompile = do runRecompile = do
-- assume that the conf directory contains a valid stack project -- assume that the conf directory contains a valid stack project
-- TODO this is hacky AF
confDir <- getXMonadDir confDir <- getXMonadDir
spawn $ cmd confDir spawnAt confDir $ fmtCmd "stack" ["install"]
where #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "compilation succeeded" }
cmd c = fmtCmd "cd" [c] #!|| fmtNotifyCmd defNoteError { body = Just $ Text "compilation failed" }
#!&& fmtCmd "stack" ["install", ":xmonad"]
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "compilation succeeded" } -- runRecompile :: X ()
#!|| fmtNotifyCmd defNoteError { body = Just $ Text "compilation failed" } -- runRecompile = do
-- -- assume that the conf directory contains a valid stack project
-- -- TODO this is hacky AF
-- confDir <- getXMonadDir
-- spawnCmdAt confDir "stack" ["install"]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Screen capture commands -- | Screen capture commands

View File

@ -18,9 +18,8 @@ import DBus.Client
import Graphics.X11.Xlib.Display import Graphics.X11.Xlib.Display
import Graphics.X11.XScreenSaver import Graphics.X11.XScreenSaver
import XMonad
import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Common
import XMonad.Internal.Shell import XMonad.Internal.Process
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Low-level functions -- | Low-level functions
@ -31,7 +30,7 @@ toggle :: IO SSState
toggle = do toggle = do
st <- query st <- query
-- TODO figure out how not to do this with shell commands -- TODO figure out how not to do this with shell commands
spawn $ fmtCmd "xset" $ "s" : args st void $ createProcess' $ proc "xset" $ "s" : args st
-- TODO this assumes the command succeeds -- TODO this assumes the command succeeds
return $ not st return $ not st
where where

View File

@ -1,34 +1,29 @@
{-# LANGUAGE LambdaCase #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Functions for managing processes -- | Functions for managing processes
module XMonad.Internal.Process module XMonad.Internal.Process
( waitUntilExit ( waitUntilExit
, killPID , killHandle
, spawnPipe' , spawnPipe
, createProcess'
, proc'
, shell'
, spawn
, spawnAt
, module System.Process
) where ) where
import Control.Concurrent import Control.Concurrent
import Control.Exception import Control.Exception
import Control.Monad import Control.Monad
import Control.Monad.IO.Class
import System.Directory import System.Directory
import System.Exit import System.Exit
import System.IO import System.IO
import System.Posix.IO
import System.Posix.Process
import System.Posix.Signals import System.Posix.Signals
import System.Posix.Types import System.Process
import System.Process hiding (createPipe)
import System.Process.Internals
( ProcessHandle__ (ClosedHandle, OpenHandle)
, mkProcessHandle
, withProcessHandle
)
import XMonad.Core import XMonad.Core hiding (spawn)
-- | Block until a PID has exited (in any form) -- | Block until a PID has exited (in any form)
-- ASSUMPTION on linux PIDs will always increase until they overflow, in which -- ASSUMPTION on linux PIDs will always increase until they overflow, in which
@ -41,29 +36,39 @@ waitUntilExit pid = do
res <- doesDirectoryExist $ "/proc/" ++ show pid res <- doesDirectoryExist $ "/proc/" ++ show pid
when res $ threadDelay 100000 >> waitUntilExit pid when res $ threadDelay 100000 >> waitUntilExit pid
killPID :: ProcessID -> IO () killHandle :: ProcessHandle -> IO ()
killPID pid = do killHandle ph = do
h <- mkProcessHandle pid False pid <- getPid ph
-- this may fail of the PID does not exist forM_ pid $ signalProcess sigTERM
_ <- try $ sendSIGTERM h :: IO (Either IOException ())
-- this may fail if the process exits instantly and the handle -- this may fail if the process exits instantly and the handle
-- is destroyed by the time we get to this line (I think?) -- is destroyed by the time we get to this line (I think?)
_ <- try $ waitForProcess h :: IO (Either IOException ExitCode) void (try $ waitForProcess ph :: IO (Either IOException ExitCode))
return ()
where
sendSIGTERM h = withProcessHandle h $ \case
OpenHandle _ -> signalProcess sigTERM pid
ClosedHandle _ -> return ()
_ -> return () -- this should never happen
spawnPipe' :: MonadIO m => String -> m (ProcessID, Handle) withDefaultSignalHandlers :: IO a -> IO a
spawnPipe' x = liftIO $ do withDefaultSignalHandlers =
(rd, wr) <- createPipe bracket_ uninstallSignalHandlers installSignalHandlers
setFdOption wr CloseOnExec True
h <- fdToHandle wr 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
shell' :: String -> CreateProcess
shell' = addGroupSession . shell
proc' :: FilePath -> [String] -> CreateProcess
proc' cmd args = addGroupSession $ proc cmd args
spawn :: String -> X ()
spawn = io . void . createProcess' . shell'
spawnAt :: FilePath -> String -> X ()
spawnAt fp cmd = io $ void $ createProcess' $ (shell' cmd) { cwd = Just fp }
spawnPipe :: String -> IO (Handle, ProcessHandle)
spawnPipe cmd = do
-- ASSUME creating a pipe will always succeed in making a Just Handle
(Just h, _, _, p) <- createProcess' $ (shell cmd) { std_in = CreatePipe }
hSetBuffering h LineBuffering hSetBuffering h LineBuffering
p <- xfork $ do return (h, p)
_ <- dupTo rd stdInput
executeFile "/bin/sh" False ["-c", x] Nothing
closeFd rd
return (p, h)

View File

@ -9,7 +9,8 @@ module XMonad.Internal.Shell
, (#!>>) , (#!>>)
) where ) where
import XMonad import XMonad.Core (X)
import XMonad.Internal.Process
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Opening subshell -- | Opening subshell