WIP use sane process interface for keybound commands

This commit is contained in:
Nathan Dwarshuis 2022-12-29 12:01:40 -05:00
parent 70541ca5b1
commit 0a848c4aa7
7 changed files with 50 additions and 56 deletions

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -7,14 +7,14 @@ module XMonad.Internal.Shell
( fmtCmd ( fmtCmd
, spawnCmd , spawnCmd
, spawn , spawn
, spawnAt
, spawnStdin
, doubleQuote , doubleQuote
, singleQuote , singleQuote
, skip , skip
, runProcessX , runProcess
, spawnAt , proc
, proc' , shell
, shell'
, createProcess'
, (#!&&) , (#!&&)
, (#!||) , (#!||)
, (#!|) , (#!|)
@ -24,47 +24,48 @@ module XMonad.Internal.Shell
import Control.Monad.IO.Class import Control.Monad.IO.Class
import RIO import RIO
import qualified RIO.ByteString.Lazy as B
import qualified RIO.Text as T import qualified RIO.Text as T
import System.Process import qualified System.Process.Typed as P
import qualified XMonad.Core as X import qualified XMonad.Core as X
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Opening subshell -- | Opening subshell
-- https://github.com/xmonad/xmonad/issues/113
withDefaultSignalHandlers :: IO a -> IO a withDefaultSignalHandlers :: IO a -> IO a
withDefaultSignalHandlers = withDefaultSignalHandlers =
bracket_ X.uninstallSignalHandlers X.installSignalHandlers 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 :: MonadIO m => FilePath -> [T.Text] -> m ()
spawnCmd cmd args = spawn $ T.unpack $ fmtCmd cmd args spawnCmd cmd = spawn . fmtCmd cmd
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Formatting commands -- | Formatting commands