WIP use sane process interface for keybound commands
This commit is contained in:
parent
70541ca5b1
commit
0a848c4aa7
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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" }
|
||||||
|
|
|
@ -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"
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue