From 9b3f69bb1139563875b09c1d40c635026af1f219 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 6 Apr 2020 00:14:56 -0400 Subject: [PATCH] ENH use process package instead of unix for spawning subshells --- bin/xmonad.hs | 7 ++- lib/XMonad/Internal/Command/DMenu.hs | 12 ++-- lib/XMonad/Internal/Command/Desktop.hs | 20 ++++--- lib/XMonad/Internal/DBus/Screensaver.hs | 5 +- lib/XMonad/Internal/Process.hs | 79 +++++++++++++------------ lib/XMonad/Internal/Shell.hs | 3 +- 6 files changed, 67 insertions(+), 59 deletions(-) diff --git a/bin/xmonad.hs b/bin/xmonad.hs index 8ed7bf5..c052010 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -61,7 +61,7 @@ import XMonad.Util.NamedActions main :: IO () main = do cl <- startXMonadService - (p, h) <- spawnPipe' "xmobar" + (h, p) <- spawnPipe "xmobar" _ <- forkIO runPowermon _ <- forkIO $ runWorkspaceMon allDWs let ts = ThreadState @@ -91,14 +91,14 @@ main = do data ThreadState = ThreadState { client :: Client - , childPIDs :: [Pid] + , childPIDs :: [ProcessHandle] , childHandles :: [Handle] } -- TODO shouldn't this be run by a signal handler? runCleanup :: ThreadState -> X () runCleanup ts = io $ do - mapM_ killPID $ childPIDs ts + mapM_ killHandle $ childPIDs ts stopXMonadService $ client ts -------------------------------------------------------------------------------- @@ -229,6 +229,7 @@ data HIDE = HIDE instance Transformer HIDE Window where transform _ x k = k EmptyLayout (\EmptyLayout -> x) +-- TODO toggle back to normal when a new window is opened runHide :: X () runHide = sendMessage $ Toggle HIDE diff --git a/lib/XMonad/Internal/Command/DMenu.hs b/lib/XMonad/Internal/Command/DMenu.hs index c9934a8..476332d 100644 --- a/lib/XMonad/Internal/Command/DMenu.hs +++ b/lib/XMonad/Internal/Command/DMenu.hs @@ -22,11 +22,11 @@ import Graphics.X11.Xrandr import System.IO -import XMonad.Core +import XMonad.Core hiding (spawn) +import XMonad.Internal.Process import XMonad.Internal.Shell import XMonad.StackSet import XMonad.Util.NamedActions -import XMonad.Util.Run -------------------------------------------------------------------------------- -- | Fix rofi screen indexing limitations @@ -96,11 +96,9 @@ runShowKeys x = addName "Show Keybindings" $ do name <- getMonitorName case name of Just n -> do - h <- spawnPipe $ cmd n - io $ hPutStr h (unlines $ showKm x) - io $ hClose h - return () - -- TODO put better error message here + (h, _, _, _) <- io $ createProcess' $ (shell' $ cmd n) + { std_in = CreatePipe } + io $ forM_ h $ \h' -> hPutStr h' (unlines $ showKm x) >> hClose h' Nothing -> io $ putStrLn "fail" where cmd name = fmtCmd myDmenuCmd [ "-dmenu" diff --git a/lib/XMonad/Internal/Command/Desktop.hs b/lib/XMonad/Internal/Command/Desktop.hs index db7b327..a00c2d9 100644 --- a/lib/XMonad/Internal/Command/Desktop.hs +++ b/lib/XMonad/Internal/Command/Desktop.hs @@ -33,10 +33,11 @@ import Control.Monad (void) import System.Directory (getHomeDirectory) import XMonad.Actions.Volume -import XMonad.Core +import XMonad.Core hiding (spawn) import XMonad.Internal.DBus.IntelBacklight import XMonad.Internal.DBus.Screensaver import XMonad.Internal.Notify +import XMonad.Internal.Process import XMonad.Internal.Shell import XMonad.Operations @@ -124,14 +125,17 @@ runRestart = restart "xmonad" True runRecompile :: X () runRecompile = do -- assume that the conf directory contains a valid stack project - -- TODO this is hacky AF confDir <- getXMonadDir - spawn $ cmd confDir - where - cmd c = fmtCmd "cd" [c] - #!&& fmtCmd "stack" ["install", ":xmonad"] - #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "compilation succeeded" } - #!|| fmtNotifyCmd defNoteError { body = Just $ Text "compilation failed" } + spawnAt confDir $ fmtCmd "stack" ["install"] + #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "compilation succeeded" } + #!|| fmtNotifyCmd defNoteError { body = Just $ Text "compilation failed" } + +-- runRecompile :: X () +-- 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 diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index c31eaeb..993f002 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/lib/XMonad/Internal/DBus/Screensaver.hs @@ -18,9 +18,8 @@ import DBus.Client import Graphics.X11.Xlib.Display import Graphics.X11.XScreenSaver -import XMonad import XMonad.Internal.DBus.Common -import XMonad.Internal.Shell +import XMonad.Internal.Process -------------------------------------------------------------------------------- -- | Low-level functions @@ -31,7 +30,7 @@ toggle :: IO SSState toggle = do st <- query -- 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 return $ not st where diff --git a/lib/XMonad/Internal/Process.hs b/lib/XMonad/Internal/Process.hs index 76f6592..aa7bb4d 100644 --- a/lib/XMonad/Internal/Process.hs +++ b/lib/XMonad/Internal/Process.hs @@ -1,34 +1,29 @@ -{-# LANGUAGE LambdaCase #-} - -------------------------------------------------------------------------------- -- | Functions for managing processes module XMonad.Internal.Process ( waitUntilExit - , killPID - , spawnPipe' + , killHandle + , spawnPipe + , createProcess' + , proc' + , shell' + , spawn + , spawnAt + , module System.Process ) where import Control.Concurrent import Control.Exception import Control.Monad -import Control.Monad.IO.Class import System.Directory import System.Exit import System.IO -import System.Posix.IO -import System.Posix.Process import System.Posix.Signals -import System.Posix.Types -import System.Process hiding (createPipe) -import System.Process.Internals - ( ProcessHandle__ (ClosedHandle, OpenHandle) - , mkProcessHandle - , withProcessHandle - ) +import System.Process -import XMonad.Core +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 @@ -41,29 +36,39 @@ waitUntilExit pid = do res <- doesDirectoryExist $ "/proc/" ++ show pid when res $ threadDelay 100000 >> waitUntilExit pid -killPID :: ProcessID -> IO () -killPID pid = do - h <- mkProcessHandle pid False - -- this may fail of the PID does not exist - _ <- try $ sendSIGTERM h :: IO (Either IOException ()) +killHandle :: ProcessHandle -> IO () +killHandle ph = 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?) - _ <- try $ waitForProcess h :: IO (Either IOException ExitCode) - return () - where - sendSIGTERM h = withProcessHandle h $ \case - OpenHandle _ -> signalProcess sigTERM pid - ClosedHandle _ -> return () - _ -> return () -- this should never happen + void (try $ waitForProcess ph :: IO (Either IOException ExitCode)) -spawnPipe' :: MonadIO m => String -> m (ProcessID, Handle) -spawnPipe' x = liftIO $ do - (rd, wr) <- createPipe - setFdOption wr CloseOnExec True - h <- fdToHandle wr +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 + +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 - p <- xfork $ do - _ <- dupTo rd stdInput - executeFile "/bin/sh" False ["-c", x] Nothing - closeFd rd - return (p, h) + return (h, p) diff --git a/lib/XMonad/Internal/Shell.hs b/lib/XMonad/Internal/Shell.hs index 279e5f6..ed38666 100644 --- a/lib/XMonad/Internal/Shell.hs +++ b/lib/XMonad/Internal/Shell.hs @@ -9,7 +9,8 @@ module XMonad.Internal.Shell , (#!>>) ) where -import XMonad +import XMonad.Core (X) +import XMonad.Internal.Process -------------------------------------------------------------------------------- -- | Opening subshell