WIP use sane process interface for keybound commands

bin/xmonad.hs

@@ -55,7 +55,7 @@ import           XMonad.Internal.DBus.Brightness.IntelBacklight
 import           XMonad.Internal.DBus.Control
 import           XMonad.Internal.DBus.Removable
 import           XMonad.Internal.DBus.Screensaver
-import           XMonad.Internal.Shell
+import           XMonad.Internal.Shell                          hiding (proc)
 import qualified XMonad.Internal.Theme                          as XT
 import           XMonad.Layout.MultiToggle
 import           XMonad.Layout.NoBorders

lib/Data/Internal/Dependency.hs

@@ -137,7 +137,7 @@ import           System.Process.Typed   (nullStream)
 
 import           XMonad.Core            (X, io)
 import           XMonad.Internal.IO
-import           XMonad.Internal.Shell
+import           XMonad.Internal.Shell  hiding (proc, runProcess)
 import           XMonad.Internal.Theme
 
 --------------------------------------------------------------------------------

lib/XMonad/Internal/Command/DMenu.hs

@@ -17,8 +17,7 @@ module XMonad.Internal.Command.DMenu
   , runAutorandrMenu
   ) where
 
-import           Control.Monad.Reader
+import qualified Data.ByteString.Char8           as BC
-
 import           Data.Internal.DBus
 import           Data.Internal.Dependency
 
@@ -26,14 +25,13 @@ import           DBus
 
 import           Graphics.X11.Types
 
+import qualified RIO.ByteString.Lazy             as B
 import qualified RIO.Text                        as T
 
 import           System.Directory
     ( XdgDirectory (..)
     , getXdgDirectory
     )
-import           System.IO
-import           System.Process
 
 import           XMonad.Core                     hiding (spawn)
 import           XMonad.Internal.Command.Desktop
@@ -203,9 +201,8 @@ showKeysDMenu = Subfeature
   }
 
 showKeys :: [((KeyMask, KeySym), NamedAction)] -> X ()
-showKeys kbs = io $ do
+showKeys kbs = io $ spawnStdin i cmd
-      (h, _, _, _) <- createProcess' $ (shell' $ T.unpack cmd) { std_in = CreatePipe }
-      forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h'
   where
+    i = B.fromStrict $ BC.pack $ unlines $ showKm kbs
     cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"]
       ++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs

lib/XMonad/Internal/Command/Desktop.hs

@@ -50,7 +50,7 @@ import           DBus
 
 import           RIO
 import           RIO.FilePath
-import           RIO.Process
+import qualified RIO.Process                 as P
 import qualified RIO.Text                    as T
 
 import           System.Directory
@@ -58,10 +58,10 @@ import           System.Environment
 import           System.Posix.User
 
 import           XMonad.Actions.Volume
-import           XMonad.Core                 hiding (spawn)
+import           XMonad.Core                 as XC
 import           XMonad.Internal.DBus.Common
 import           XMonad.Internal.Notify
-import           XMonad.Internal.Shell
+import           XMonad.Internal.Shell       as S
 import           XMonad.Operations
 
 --------------------------------------------------------------------------------
@@ -134,8 +134,7 @@ runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
   where
     deps = listToAnds (socketExists "tmux" [] socketName)
       $ fmap (sysExe myTermPkgs) [myTerm, "tmux", "bash"]
-    act = spawn
+    act = S.spawn
-      $ T.unpack
       $ fmtCmd "tmux" ["has-session"]
       #!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c]
       #!|| fmtNotifyCmd defNoteError { body = Just $ Text msg }
@@ -250,22 +249,22 @@ runNotificationContext =
 -- | System commands
 
 -- this is required for some vpn's to work properly with network-manager
-runNetAppDaemon :: Maybe SysClient -> Sometimes (FIO (Process () () ()))
+runNetAppDaemon :: Maybe SysClient -> Sometimes (FIO (P.Process () () ()))
 runNetAppDaemon cl = Sometimes "network applet" xpfVPN
   [Subfeature (DBusRoot_ cmd tree cl) "NM-applet"]
   where
     tree = toAnd_ app $ Bus networkManagerPkgs networkManagerBus
     app = DBusIO $ sysExe [Package Official "network-manager-applet"] "nm-applet"
-    cmd _ = proc "nm-applet" [] (startProcess . setCreateGroup True)
+    cmd _ = P.proc "nm-applet" [] (P.startProcess . P.setCreateGroup True)
 
 runToggleBluetooth :: Maybe SysClient -> SometimesX
 runToggleBluetooth cl = Sometimes "bluetooth toggle" xpfBluetooth
   [Subfeature (DBusRoot_ cmd tree cl) "bluetoothctl"]
   where
     tree = And_ (Only_ $ DBusIO $ sysExe bluetoothPkgs myBluetooth) (Only_ $ Bus [] btBus)
-    cmd _ = spawn
+    cmd _ = S.spawn
-      $ T.unpack
+      $ fmtCmd myBluetooth ["show"]
-      $ T.unwords [T.pack myBluetooth, "show | grep -q \"Powered: no\""]
+      #!| "grep -q \"Powered: no\""
       #!&& "a=on"
       #!|| "a=off"
       #!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"]
@@ -275,11 +274,12 @@ runToggleEthernet :: SometimesX
 runToggleEthernet = Sometimes "ethernet toggle" xpfEthernet
   [Subfeature root "nmcli"]
   where
-    root = IORoot (spawn . T.unpack . cmd) $ And1 (Only readEthernet) $ Only_
+    root = IORoot cmd $ And1 (Only readEthernet) $ Only_
       $ sysExe networkManagerPkgs "nmcli"
     -- TODO make this less noisy
-    cmd iface =
+    cmd iface = S.spawn
-      T.unwords ["nmcli -g GENERAL.STATE device show", iface, "| grep -q disconnected"]
+      $ fmtCmd "nmcli" ["-g", "GENERAL.STATE", "device", "show", iface]
+      #!| "grep -q disconnected"
       #!&& "a=connect"
       #!|| "a=disconnect"
       #!>> fmtCmd "nmcli" ["device", "$a", iface]
@@ -297,7 +297,6 @@ runRecompile = do
   -- assume that the conf directory contains a valid stack project
   confDir <- asks (cfgDir . directories)
   spawnAt confDir
-    $ T.unpack
     $ fmtCmd "stack" ["install"]
     #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "compilation succeeded" }
     #!|| fmtNotifyCmd defNoteError { body = Just $ Text "compilation failed" }

lib/XMonad/Internal/Command/Power.hs

@@ -36,7 +36,7 @@ import           Graphics.X11.Types
 
 import           RIO
 import           RIO.FilePath
-import           RIO.Process
+import qualified RIO.Process                 as P
 import qualified RIO.Text                    as T
 
 import           System.Directory
@@ -88,12 +88,12 @@ runReboot = spawn "systemctl reboot"
 --------------------------------------------------------------------------------
 -- | Autolock
 
-runAutolock :: Sometimes (FIO (Process () () ()))
+runAutolock :: Sometimes (FIO (P.Process () () ()))
 runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd
   where
     tree = And_ (Only_ $ sysExe [Package Official "xss-lock"] "xss-lock")
       $ Only_ $ IOSometimes_ runScreenLock
-    cmd = proc "xss-lock" ["--ignore-sleep", "screenlock"] (startProcess . setCreateGroup True)
+    cmd = P.proc "xss-lock" ["--ignore-sleep", "screenlock"] (P.startProcess . P.setCreateGroup True)
 
 --------------------------------------------------------------------------------
 -- | Confirmation prompts
@@ -148,8 +148,7 @@ runOptimusPrompt' fb = do
   where
     switch mode = confirmPrompt' (prompt mode) (cmd mode) fb
     prompt mode = T.concat ["gpu switch to ", mode, "?"]
-    cmd mode = spawn $
+    cmd mode = spawn
-      T.unpack
       $ T.pack myPrimeOffload
       #!&& T.unwords [T.pack myOptimusManager, "--switch", mode, "--no-confirm"]
       #!&& "killall xmonad"

lib/XMonad/Internal/DBus/Screensaver.hs

@@ -23,8 +23,6 @@ import qualified DBus.Introspection          as I
 import           Graphics.X11.XScreenSaver
 import           Graphics.X11.Xlib.Display
 
-import           System.Process
-
 import           XMonad.Internal.DBus.Common
 import           XMonad.Internal.Shell
 
@@ -42,7 +40,7 @@ toggle = do
   let args = if st then ["off", "-dpms"] else ["on", "+dpms"]
   -- this needs to be done with shell commands, because as far as I know there
   -- are no Haskell bindings for DPMSDisable/Enable (from libxext)
-  rc <- runProcessX (proc ssExecutable $ "s" : args) ""
+  rc <- runProcess (proc ssExecutable $ "s" : args)
   return $ if rc == ExitSuccess then not st else st
 
 query :: IO SSState

lib/XMonad/Internal/Shell.hs

@@ -7,14 +7,14 @@ module XMonad.Internal.Shell
   ( fmtCmd
   , spawnCmd
   , spawn
+  , spawnAt
+  , spawnStdin
   , doubleQuote
   , singleQuote
   , skip
-  , runProcessX
+  , runProcess
-  , spawnAt
+  , proc
-  , proc'
+  , shell
-  , shell'
-  , createProcess'
   , (#!&&)
   , (#!||)
   , (#!|)
@@ -24,47 +24,48 @@ module XMonad.Internal.Shell
 import           Control.Monad.IO.Class
 
 import           RIO
+import qualified RIO.ByteString.Lazy    as B
 import qualified RIO.Text               as T
 
-import           System.Process
+import qualified System.Process.Typed   as P
 
 import qualified XMonad.Core            as X
 
 --------------------------------------------------------------------------------
 -- | Opening subshell
+-- https://github.com/xmonad/xmonad/issues/113
 
 withDefaultSignalHandlers :: IO a -> IO a
 withDefaultSignalHandlers =
   bracket_ X.uninstallSignalHandlers X.installSignalHandlers
 
-addGroupSession :: CreateProcess -> CreateProcess
+addGroupSession :: P.ProcessConfig x y z -> P.ProcessConfig x y z
-addGroupSession cp = cp { create_group = True, new_session = True }
+addGroupSession = P.setCreateGroup True . P.setNewSession True
 
-createProcess' :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
+-- readProcess :: P.ProcessConfig a b c -> IO (ExitCode, B.ByteString, B.ByteString)
-createProcess' = withDefaultSignalHandlers . createProcess
+-- readProcess = withDefaultSignalHandlers . P.readProcess
 
-readProcessX :: CreateProcess -> String -> IO (ExitCode, T.Text, T.Text)
+runProcess :: P.ProcessConfig a b c -> IO ExitCode
-readProcessX c i = withDefaultSignalHandlers $ do
+runProcess = withDefaultSignalHandlers . P.runProcess
-  (r, e, p) <- readCreateProcessWithExitCode c i
-  return (r, T.pack e, T.pack p)
 
-runProcessX :: CreateProcess -> String -> IO ExitCode
+shell :: T.Text -> P.ProcessConfig () () ()
-runProcessX c i = (\(r, _, _) -> r) <$> readProcessX c i
+shell = addGroupSession . P.shell . T.unpack
 
-shell' :: String -> CreateProcess
+proc :: FilePath -> [T.Text] -> P.ProcessConfig () () ()
-shell' = addGroupSession . shell
+proc cmd args = addGroupSession $ P.proc cmd (T.unpack <$> args)
 
-proc' :: FilePath -> [String] -> CreateProcess
+spawn :: MonadIO m => T.Text -> m ()
-proc' cmd args = addGroupSession $ proc cmd args
+spawn = liftIO . void . P.startProcess . shell
 
-spawn :: MonadIO m => String -> m ()
+spawnAt :: MonadIO m => FilePath -> T.Text -> m ()
-spawn = liftIO . void . createProcess' . shell'
+spawnAt fp = liftIO . void . P.startProcess . P.setWorkingDir fp . shell
 
-spawnAt :: MonadIO m => FilePath -> String -> m ()
+spawnStdin :: MonadIO m => B.ByteString -> T.Text -> m ()
-spawnAt fp cmd = liftIO $ void $ createProcess' $ (shell' cmd) { cwd = Just fp }
+spawnStdin i =
+  liftIO . void . P.startProcess . P.setStdin (P.byteStringInput i) . shell
 
 spawnCmd :: MonadIO m => FilePath -> [T.Text] -> m ()
-spawnCmd cmd args = spawn $ T.unpack $ fmtCmd cmd args
+spawnCmd cmd = spawn . fmtCmd cmd
 
 --------------------------------------------------------------------------------
 -- | Formatting commands