ENH use process package instead of unix for spawning subshells
This commit is contained in:
parent
d4cdd69b80
commit
9b3f69bb11
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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"
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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)
|
|
||||||
|
|
|
@ -9,7 +9,8 @@ module XMonad.Internal.Shell
|
||||||
, (#!>>)
|
, (#!>>)
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import XMonad
|
import XMonad.Core (X)
|
||||||
|
import XMonad.Internal.Process
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Opening subshell
|
-- | Opening subshell
|
||||||
|
|
Loading…
Reference in New Issue