ENH use process package instead of unix for spawning subshells

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
 

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"

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,15 +125,18 @@ 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"]
+  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
 

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

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)

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