ENH make desktop dependencies more robust

This commit is contained in:
Nathan Dwarshuis 2022-07-07 23:22:48 -04:00
parent 8d495123dc
commit a7e7eee2a8
3 changed files with 61 additions and 38 deletions

View File

@ -635,9 +635,9 @@ externalBindings ts db =
[ KeyBinding "M-q" "close window" $ ftrAlways "kill window function" kill1 [ KeyBinding "M-q" "close window" $ ftrAlways "kill window function" kill1
, KeyBinding "M-r" "run program" $ Left runCmdMenu , KeyBinding "M-r" "run program" $ Left runCmdMenu
, KeyBinding "M-<Space>" "warp pointer" $ ftrAlways "warp function" $ warpToWindow 0.5 0.5 , KeyBinding "M-<Space>" "warp pointer" $ ftrAlways "warp function" $ warpToWindow 0.5 0.5
, KeyBinding "M-C-s" "capture area" $ Left runAreaCapture , KeyBinding "M-C-s" "capture area" $ Left $ runAreaCapture ses
, KeyBinding "M-C-S-s" "capture screen" $ Left runScreenCapture , KeyBinding "M-C-S-s" "capture screen" $ Left $ runScreenCapture ses
, KeyBinding "M-C-d" "capture desktop" $ Left runDesktopCapture , KeyBinding "M-C-d" "capture desktop" $ Left $ runDesktopCapture ses
, KeyBinding "M-C-b" "browse captures" $ Left runCaptureBrowser , KeyBinding "M-C-b" "browse captures" $ Left runCaptureBrowser
-- , ("M-C-S-s", "capture focused window", spawn myWindowCap) -- , ("M-C-S-s", "capture focused window", spawn myWindowCap)
] ]
@ -653,10 +653,10 @@ externalBindings ts db =
] ]
, KeyGroup "Dunst" , KeyGroup "Dunst"
[ KeyBinding "M-`" "dunst history" $ Left runNotificationHistory [ KeyBinding "M-`" "dunst history" $ Left $ runNotificationHistory ses
, KeyBinding "M-S-`" "dunst close" $ Left runNotificationClose , KeyBinding "M-S-`" "dunst close" $ Left $ runNotificationClose ses
, KeyBinding "M-M1-`" "dunst context menu" $ Left runNotificationContext , KeyBinding "M-M1-`" "dunst context menu" $ Left $ runNotificationContext ses
, KeyBinding "M-C-`" "dunst close all" $ Left runNotificationCloseAll , KeyBinding "M-C-`" "dunst close all" $ Left $ runNotificationCloseAll ses
] ]
, KeyGroup "System" , KeyGroup "System"

View File

@ -41,14 +41,14 @@ module XMonad.Internal.Command.Desktop
import Control.Monad (void) import Control.Monad (void)
import Control.Monad.IO.Class import Control.Monad.IO.Class
import DBus
import DBus.Client import DBus.Client
import System.Directory import System.Directory
( createDirectoryIfMissing
, getHomeDirectory
)
import System.Environment import System.Environment
import System.FilePath import System.FilePath
import System.Posix.Files
import System.Posix.User
import XMonad (asks) import XMonad (asks)
import XMonad.Actions.Volume import XMonad.Actions.Volume
@ -99,17 +99,33 @@ volumeChangeSound = "smb_fireball.wav"
runTerm :: SometimesX runTerm :: SometimesX
runTerm = sometimesExe "terminal" "urxvt" True myTerm runTerm = sometimesExe "terminal" "urxvt" True myTerm
-- TODO test that tmux is actually running (/tmp/tmux-<UID>/default)
runTMux :: SometimesX runTMux :: SometimesX
runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
where where
deps = listToAnds (sysExe myTerm) $ fmap sysExe ["tmux", "bash"] deps = listToAnds (socketExists socketName)
$ fmap sysExe [myTerm, "tmux", "bash"]
act = spawn act = spawn
$ "tmux has-session" $ "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 }
c = "exec tmux attach-session -d" c = "exec tmux attach-session -d"
msg = "could not connect to tmux session" msg = "could not connect to tmux session"
socketName = do
u <- getEffectiveUserID
t <- getTemporaryDirectory
return $ t </> "tmux-" ++ show u </> "default"
socketExists :: IO FilePath -> IODependency_
socketExists getPath = IOTest_ "find tmux socket current user" $ do
p <- getPath
e <- fileExist p
s <- isSocket <$> getFileStatus p
return $ case (e, s) of
(True, True) -> Nothing
(False, _) -> toErr $ "could not find socket at " ++ p
(_, False) -> toErr $ p ++ " is not a socket"
where
toErr = Just . Msg Error
runCalc :: SometimesX runCalc :: SometimesX
runCalc = sometimesIO_ "calculator" "R" deps act runCalc = sometimesIO_ "calculator" "R" deps act
@ -120,10 +136,13 @@ runCalc = sometimesIO_ "calculator" "R" deps act
runBrowser :: SometimesX runBrowser :: SometimesX
runBrowser = sometimesExe "web browser" "brave" False myBrowser runBrowser = sometimesExe "web browser" "brave" False myBrowser
-- TODO test that emacs is actually running (/run/user/1000/emacs/server)
runEditor :: SometimesX runEditor :: SometimesX
runEditor = sometimesExeArgs "text editor" "emacs" True myEditor runEditor = sometimesIO_ "text editor" "emacs" tree cmd
["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"] where
cmd = spawnCmd myEditor
["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
tree = toAnd_ (sysExe myEditor) (socketExists socketName)
socketName = (</> "emacs" </> "server") <$> getEnv "XDG_RUNTIME_DIR"
runFileManager :: SometimesX runFileManager :: SometimesX
runFileManager = sometimesExe "file browser" "pcmanfm" True "pcmanfm" runFileManager = sometimesExe "file browser" "pcmanfm" True "pcmanfm"
@ -177,25 +196,27 @@ runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Notification control -- | Notification control
-- TODO test that dunst is actually running (org.freedesktop.Notifications/org.dunstproject.cmd0) runNotificationCmd :: String -> FilePath -> Maybe Client -> SometimesX
runNotificationCmd :: String -> FilePath -> SometimesX runNotificationCmd n arg cl =
runNotificationCmd n arg = sometimesIO_ (n ++ " control") "dunstctl" tree cmd sometimesDBus cl (n ++ " control") "dunstctl" tree cmd
where where
tree = Only_ $ sysExe myNotificationCtrl cmd _ = spawnCmd myNotificationCtrl [arg]
cmd = spawnCmd myNotificationCtrl [arg] tree = toAnd_ (DBusIO $ sysExe myNotificationCtrl)
$ Endpoint notifyBus notifyPath (interfaceName_ "org.dunstproject.cmd0")
$ Method_ $ memberName_ "NotificationAction"
runNotificationClose :: SometimesX runNotificationClose :: Maybe Client -> SometimesX
runNotificationClose = runNotificationCmd "close notification" "close" runNotificationClose = runNotificationCmd "close notification" "close"
runNotificationCloseAll :: SometimesX runNotificationCloseAll :: Maybe Client -> SometimesX
runNotificationCloseAll = runNotificationCloseAll =
runNotificationCmd "close all notifications" "close-all" runNotificationCmd "close all notifications" "close-all"
runNotificationHistory :: SometimesX runNotificationHistory :: Maybe Client -> SometimesX
runNotificationHistory = runNotificationHistory =
runNotificationCmd "see notification history" "history-pop" runNotificationCmd "see notification history" "history-pop"
runNotificationContext :: SometimesX runNotificationContext :: Maybe Client -> SometimesX
runNotificationContext = runNotificationContext =
runNotificationCmd "open notification context" "context" runNotificationCmd "open notification context" "context"
@ -264,13 +285,6 @@ runRecompile = do
#!&& 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" }
-- 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 -- | Screen capture commands
@ -288,22 +302,23 @@ getCaptureDir = do
where where
fallback = (</> ".local/share") <$> getHomeDirectory fallback = (</> ".local/share") <$> getHomeDirectory
-- TODO test that flameshot is actually running (Bus org.flameshot.Flameshot) runFlameshot :: String -> String -> Maybe Client -> SometimesX
runFlameshot :: String -> String -> SometimesX runFlameshot n mode cl = sometimesDBus cl n myCapture tree cmd
runFlameshot n mode = sometimesIO_ n myCapture where
(Only_ $ sysExe myCapture) $ spawnCmd myCapture [mode] cmd _ = spawnCmd myCapture [mode]
tree = toAnd_ (DBusIO $ sysExe myCapture) $ Bus $ busName_ "org.flameshot.Flameshot"
-- TODO this will steal focus from the current window (and puts it -- TODO this will steal focus from the current window (and puts it
-- in the root window?) ...need to fix -- in the root window?) ...need to fix
runAreaCapture :: SometimesX runAreaCapture :: Maybe Client -> SometimesX
runAreaCapture = runFlameshot "screen area capture" "gui" runAreaCapture = runFlameshot "screen area capture" "gui"
-- myWindowCap = "screencap -w" --external script -- myWindowCap = "screencap -w" --external script
runDesktopCapture :: SometimesX runDesktopCapture :: Maybe Client -> SometimesX
runDesktopCapture = runFlameshot "fullscreen capture" "full" runDesktopCapture = runFlameshot "fullscreen capture" "full"
runScreenCapture :: SometimesX runScreenCapture :: Maybe Client -> SometimesX
runScreenCapture = runFlameshot "screen capture" "screen" runScreenCapture = runFlameshot "screen capture" "screen"
runCaptureBrowser :: SometimesX runCaptureBrowser :: SometimesX

View File

@ -4,6 +4,8 @@
module XMonad.Internal.DBus.Common module XMonad.Internal.DBus.Common
( xmonadBusName ( xmonadBusName
, btBus , btBus
, notifyBus
, notifyPath
) where ) where
import DBus import DBus
@ -14,3 +16,9 @@ xmonadBusName = busName_ "org.xmonad"
btBus :: BusName btBus :: BusName
btBus = busName_ "org.bluez" btBus = busName_ "org.bluez"
notifyBus :: BusName
notifyBus = busName_ "org.freedesktop.Notifications"
notifyPath :: ObjectPath
notifyPath = objectPath_ "/org/freedesktop/Notifications"