diff --git a/bin/xmonad.hs b/bin/xmonad.hs index c1f9b1a..316b242 100644 --- a/bin/xmonad.hs +++ b/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 diff --git a/lib/Data/Internal/Dependency.hs b/lib/Data/Internal/Dependency.hs index 4814dc2..930ce34 100644 --- a/lib/Data/Internal/Dependency.hs +++ b/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 -------------------------------------------------------------------------------- diff --git a/lib/XMonad/Internal/Command/DMenu.hs b/lib/XMonad/Internal/Command/DMenu.hs index 48fc501..1cec3a2 100644 --- a/lib/XMonad/Internal/Command/DMenu.hs +++ b/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 - (h, _, _, _) <- createProcess' $ (shell' $ T.unpack cmd) { std_in = CreatePipe } - forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h' +showKeys kbs = io $ spawnStdin i cmd where + i = B.fromStrict $ BC.pack $ unlines $ showKm kbs cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"] ++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs diff --git a/lib/XMonad/Internal/Command/Desktop.hs b/lib/XMonad/Internal/Command/Desktop.hs index e69441d..8d3befc 100644 --- a/lib/XMonad/Internal/Command/Desktop.hs +++ b/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 - $ T.unpack + act = S.spawn $ 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 - $ T.unpack - $ T.unwords [T.pack myBluetooth, "show | grep -q \"Powered: no\""] + cmd _ = S.spawn + $ fmtCmd myBluetooth ["show"] + #!| "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 = - T.unwords ["nmcli -g GENERAL.STATE device show", iface, "| grep -q disconnected"] + cmd iface = S.spawn + $ 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" } diff --git a/lib/XMonad/Internal/Command/Power.hs b/lib/XMonad/Internal/Command/Power.hs index 8f69190..f9a83b2 100644 --- a/lib/XMonad/Internal/Command/Power.hs +++ b/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 $ - T.unpack + cmd mode = spawn $ T.pack myPrimeOffload #!&& T.unwords [T.pack myOptimusManager, "--switch", mode, "--no-confirm"] #!&& "killall xmonad" diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index 17e18b4..81e8bab 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/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 diff --git a/lib/XMonad/Internal/Shell.hs b/lib/XMonad/Internal/Shell.hs index 2ec2acc..c30d1fe 100644 --- a/lib/XMonad/Internal/Shell.hs +++ b/lib/XMonad/Internal/Shell.hs @@ -7,14 +7,14 @@ module XMonad.Internal.Shell ( fmtCmd , spawnCmd , spawn + , spawnAt + , spawnStdin , doubleQuote , singleQuote , skip - , runProcessX - , spawnAt - , proc' - , shell' - , createProcess' + , runProcess + , proc + , shell , (#!&&) , (#!||) , (#!|) @@ -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 cp = cp { create_group = True, new_session = True } +addGroupSession :: P.ProcessConfig x y z -> P.ProcessConfig x y z +addGroupSession = P.setCreateGroup True . P.setNewSession True -createProcess' :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -createProcess' = withDefaultSignalHandlers . createProcess +-- readProcess :: P.ProcessConfig a b c -> IO (ExitCode, B.ByteString, B.ByteString) +-- readProcess = withDefaultSignalHandlers . P.readProcess -readProcessX :: CreateProcess -> String -> IO (ExitCode, T.Text, T.Text) -readProcessX c i = withDefaultSignalHandlers $ do - (r, e, p) <- readCreateProcessWithExitCode c i - return (r, T.pack e, T.pack p) +runProcess :: P.ProcessConfig a b c -> IO ExitCode +runProcess = withDefaultSignalHandlers . P.runProcess -runProcessX :: CreateProcess -> String -> IO ExitCode -runProcessX c i = (\(r, _, _) -> r) <$> readProcessX c i +shell :: T.Text -> P.ProcessConfig () () () +shell = addGroupSession . P.shell . T.unpack -shell' :: String -> CreateProcess -shell' = addGroupSession . shell +proc :: FilePath -> [T.Text] -> P.ProcessConfig () () () +proc cmd args = addGroupSession $ P.proc cmd (T.unpack <$> args) -proc' :: FilePath -> [String] -> CreateProcess -proc' cmd args = addGroupSession $ proc cmd args +spawn :: MonadIO m => T.Text -> m () +spawn = liftIO . void . P.startProcess . shell -spawn :: MonadIO m => String -> m () -spawn = liftIO . void . createProcess' . shell' +spawnAt :: MonadIO m => FilePath -> T.Text -> m () +spawnAt fp = liftIO . void . P.startProcess . P.setWorkingDir fp . shell -spawnAt :: MonadIO m => FilePath -> String -> m () -spawnAt fp cmd = liftIO $ void $ createProcess' $ (shell' cmd) { cwd = Just fp } +spawnStdin :: MonadIO m => B.ByteString -> T.Text -> m () +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