From 81830a8e96ff5edb7cedfc7ae4848b1faa848d70 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sat, 20 Nov 2021 19:35:24 -0500 Subject: [PATCH] ENH make better error messages for features --- bin/xmobar.hs | 45 ++--- lib/XMonad/Internal/Command/DMenu.hs | 26 +-- lib/XMonad/Internal/Command/Desktop.hs | 78 +++++---- lib/XMonad/Internal/Command/Power.hs | 9 +- lib/XMonad/Internal/Concurrent/ACPIEvent.hs | 2 +- lib/XMonad/Internal/Concurrent/Removable.hs | 11 +- lib/XMonad/Internal/DBus/Brightness/Common.hs | 46 +++-- .../DBus/Brightness/IntelBacklight.hs | 7 +- lib/XMonad/Internal/DBus/Common.hs | 38 ++--- lib/XMonad/Internal/DBus/Control.hs | 7 +- lib/XMonad/Internal/DBus/Screensaver.hs | 30 +++- lib/XMonad/Internal/Dependency.hs | 158 ++++++++++++------ 12 files changed, 272 insertions(+), 185 deletions(-) diff --git a/bin/xmobar.hs b/bin/xmobar.hs index e2422ab..f008188 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -40,12 +40,9 @@ import XMonad.Hooks.DynamicLog ) import XMonad.Internal.Command.Power (hasBattery) import XMonad.Internal.DBus.Brightness.IntelBacklight - ( curFileDep - , maxFileDep - ) -- import XMonad.Internal.DBus.Common (xmonadBus) -- import XMonad.Internal.DBus.Control (pathExists) -import XMonad.Internal.DBus.Screensaver (ssDep) +import XMonad.Internal.DBus.Screensaver (ssSignalDep) import XMonad.Internal.Dependency -- import XMonad.Internal.Shell (fmtCmd) import qualified XMonad.Internal.Theme as T @@ -226,20 +223,8 @@ dateCmd = CmdSpec -- some commands depend on the presence of interfaces that can only be -- determined at runtime; define these checks here --- noSetup :: Monad m => a -> m (Maybe a) --- noSetup = return . Just - --- toJust :: a -> Bool -> Maybe a --- toJust x b = if b then Just x else Nothing - dbusDep :: Bool -> BusName -> ObjectPath -> InterfaceName -> DBusMember -> Dependency -dbusDep usesys bus obj iface mem = DBusEndpoint - { ddDbusBus = bus - , ddDbusSystem = usesys - , ddDbusObject = obj - , ddDbusInterface = iface - , ddDbusMember = mem - } +dbusDep usesys bus obj iface mem = DBusEndpoint (Bus usesys bus) (Endpoint obj iface mem) -- in the case of network interfaces, assume that the system uses systemd in -- which case ethernet interfaces always start with "en" and wireless @@ -303,14 +288,15 @@ getWireless = do getEthernet :: IO (MaybeExe CmdSpec) getEthernet = do i <- readInterface isEthernet - evalFeature $ maybe BlankFeature (featureRun [dep] . ethernetCmd) i + evalFeature $ maybe BlankFeature (featureRun "ethernet status indicator" [dep] . ethernetCmd) i where dep = dbusDep True devBus devPath devInterface $ Method_ devGetByIP getBattery :: BarFeature getBattery = Feature { ftrAction = batteryCmd - , ftrSilent = False + , ftrName = "battery level indicator" + , ftrWarning = Default , ftrChildren = [IOTest hasBattery] } @@ -319,7 +305,8 @@ type BarFeature = Feature CmdSpec getVPN :: BarFeature getVPN = Feature { ftrAction = vpnCmd - , ftrSilent = False + , ftrName = "VPN status indicator" + , ftrWarning = Default , ftrChildren = [d, v] } where @@ -329,7 +316,8 @@ getVPN = Feature getBt :: BarFeature getBt = Feature { ftrAction = btCmd - , ftrSilent = False + , ftrName = "bluetooth status indicator" + , ftrWarning = Default , ftrChildren = [dep] } where @@ -338,22 +326,25 @@ getBt = Feature getAlsa :: BarFeature getAlsa = Feature { ftrAction = alsaCmd - , ftrSilent = False - , ftrChildren = [exe "alsactl"] + , ftrName = "volume level indicator" + , ftrWarning = Default + , ftrChildren = [Executable "alsactl"] } getBl :: BarFeature getBl = Feature { ftrAction = blCmd - , ftrSilent = False - , ftrChildren = [curFileDep, maxFileDep] + , ftrName = "Intel backlight indicator" + , ftrWarning = Default + , ftrChildren = [intelBacklightSignalDep] } getSs :: BarFeature getSs = Feature { ftrAction = ssCmd - , ftrSilent = False - , ftrChildren = [ssDep] + , ftrName = "screensaver indicator" + , ftrWarning = Default + , ftrChildren = [ssSignalDep] } getAllCommands :: [MaybeExe CmdSpec] -> IO BarRegions diff --git a/lib/XMonad/Internal/Command/DMenu.hs b/lib/XMonad/Internal/Command/DMenu.hs index 2ad8dc3..eab36b3 100644 --- a/lib/XMonad/Internal/Command/DMenu.hs +++ b/lib/XMonad/Internal/Command/DMenu.hs @@ -47,8 +47,8 @@ myDmenuNetworks = "networkmanager_dmenu" -------------------------------------------------------------------------------- -- | Other internal functions -spawnDmenuCmd :: [String] -> FeatureX -spawnDmenuCmd = featureSpawnCmd myDmenuCmd +spawnDmenuCmd :: String -> [String] -> FeatureX +spawnDmenuCmd n = featureSpawnCmd n myDmenuCmd themeArgs :: String -> [String] themeArgs hexColor = @@ -63,7 +63,7 @@ myDmenuMatchingArgs = ["-i"] -- case insensitivity -- | Exported Commands runDevMenu :: FeatureX -runDevMenu = featureRun [exe myDmenuDevices] $ do +runDevMenu = featureRun "device manager" [Executable myDmenuDevices] $ do c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml" spawnCmd myDmenuDevices $ ["-c", c] @@ -71,7 +71,7 @@ runDevMenu = featureRun [exe myDmenuDevices] $ do ++ myDmenuMatchingArgs runBwMenu :: FeatureX -runBwMenu = featureRun [exe myDmenuPasswords] $ +runBwMenu = featureRun "password manager" [Executable myDmenuPasswords] $ spawnCmd myDmenuPasswords $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs -- TODO this is weirdly inverted @@ -83,7 +83,8 @@ runShowKeys x = addName "Show Keybindings" $ do $ defNoteError { body = Just $ Text "could not display keymap" } runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> FeatureX -runDMenuShowKeys kbs = featureRun [exe myDmenuCmd] $ io $ do +runDMenuShowKeys kbs = + featureRun "keyboard shortcut menu" [Executable myDmenuCmd] $ io $ do (h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe } forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h' where @@ -91,13 +92,14 @@ runDMenuShowKeys kbs = featureRun [exe myDmenuCmd] $ io $ do ++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs runCmdMenu :: FeatureX -runCmdMenu = spawnDmenuCmd ["-show", "run"] +runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"] runAppMenu :: FeatureX -runAppMenu = spawnDmenuCmd ["-show", "drun"] +runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"] runClipMenu :: FeatureX -runClipMenu = featureRun [exe myDmenuCmd, exe "greenclip"] +runClipMenu = + featureRun "clipboard manager" [Executable myDmenuCmd, Executable "greenclip"] $ spawnCmd myDmenuCmd args where args = [ "-modi", "\"clipboard:greenclip print\"" @@ -106,10 +108,12 @@ runClipMenu = featureRun [exe myDmenuCmd, exe "greenclip"] ] ++ themeArgs "#00c44e" runWinMenu :: FeatureX -runWinMenu = spawnDmenuCmd ["-show", "window"] +runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"] runNetMenu :: FeatureX -runNetMenu = featureSpawnCmd myDmenuNetworks $ themeArgs "#ff3333" +runNetMenu = + featureSpawnCmd "network control menu" myDmenuNetworks $ themeArgs "#ff3333" runAutorandrMenu :: FeatureX -runAutorandrMenu = featureSpawnCmd myDmenuMonitors $ themeArgs "#ff0066" +runAutorandrMenu = + featureSpawnCmd "autorandr menu" myDmenuMonitors $ themeArgs "#ff0066" diff --git a/lib/XMonad/Internal/Command/Desktop.hs b/lib/XMonad/Internal/Command/Desktop.hs index e2877f3..be83121 100644 --- a/lib/XMonad/Internal/Command/Desktop.hs +++ b/lib/XMonad/Internal/Command/Desktop.hs @@ -91,11 +91,12 @@ ethernetIface = "enp7s0f1" -- | Some nice apps runTerm :: FeatureX -runTerm = featureSpawn myTerm +runTerm = featureSpawn "terminal" myTerm runTMux :: FeatureX -runTMux = featureRun [exe myTerm, exe "tmux", exe "bash"] cmd +runTMux = featureRun "terminal multiplexer" deps cmd where + deps = [Executable myTerm, Executable "tmux", Executable "bash"] cmd = spawn $ "tmux has-session" #!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c] @@ -104,35 +105,37 @@ runTMux = featureRun [exe myTerm, exe "tmux", exe "bash"] cmd msg = "could not connect to tmux session" runCalc :: FeatureX -runCalc = featureRun [exe myTerm, exe "R"] $ spawnCmd myTerm ["-e", "R"] +runCalc = featureRun "calculator" [Executable myTerm, Executable "R"] + $ spawnCmd myTerm ["-e", "R"] runBrowser :: FeatureX -runBrowser = featureSpawn myBrowser +runBrowser = featureSpawn "web browser" myBrowser runEditor :: FeatureX -runEditor = featureSpawnCmd myEditor +runEditor = featureSpawnCmd "text editor" myEditor ["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"] runFileManager :: FeatureX -runFileManager = featureSpawn "pcmanfm" +runFileManager = featureSpawn "file browser" "pcmanfm" -------------------------------------------------------------------------------- -- | Multimedia Commands -runMultimediaIfInstalled :: String -> FeatureX -runMultimediaIfInstalled cmd = featureSpawnCmd myMultimediaCtl [cmd] +runMultimediaIfInstalled :: String -> String -> FeatureX +runMultimediaIfInstalled n cmd = + featureSpawnCmd (n ++ " multimedia control") myMultimediaCtl [cmd] runTogglePlay :: FeatureX -runTogglePlay = runMultimediaIfInstalled "play-pause" +runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause" runPrevTrack :: FeatureX -runPrevTrack = runMultimediaIfInstalled "previous" +runPrevTrack = runMultimediaIfInstalled "previous track" "previous" runNextTrack :: FeatureX -runNextTrack = runMultimediaIfInstalled "next" +runNextTrack = runMultimediaIfInstalled "next track" "next" runStopPlay :: FeatureX -runStopPlay = runMultimediaIfInstalled "stop" +runStopPlay = runMultimediaIfInstalled "stop playback" "stop" -------------------------------------------------------------------------------- -- | Volume Commands @@ -146,42 +149,49 @@ playSound file = do -- paplay seems to have less latency than aplay spawnCmd "paplay" [p] -featureSound :: FilePath -> X () -> X () -> FeatureX -featureSound file pre post = featureRun [exe "paplay"] +featureSound :: String -> FilePath -> X () -> X () -> FeatureX +featureSound n file pre post = + featureRun ("volume " ++ n ++ " control") [Executable "paplay"] $ pre >> playSound file >> post runVolumeDown :: FeatureX -runVolumeDown = featureSound volumeChangeSound (return ()) $ void (lowerVolume 2) +runVolumeDown = featureSound "up" volumeChangeSound (return ()) $ void (lowerVolume 2) runVolumeUp :: FeatureX -runVolumeUp = featureSound volumeChangeSound (return ()) $ void (raiseVolume 2) +runVolumeUp = featureSound "down" volumeChangeSound (return ()) $ void (raiseVolume 2) runVolumeMute :: FeatureX -runVolumeMute = featureSound volumeChangeSound (void toggleMute) $ return () +runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return () -------------------------------------------------------------------------------- -- | Notification control -runNotificationCmd :: String -> FeatureX -runNotificationCmd cmd = featureSpawnCmd myNotificationCtrl [cmd] +runNotificationCmd :: String -> String -> FeatureX +runNotificationCmd n cmd = + featureSpawnCmd (n ++ " control") myNotificationCtrl [cmd] runNotificationClose :: FeatureX -runNotificationClose = runNotificationCmd "close" +runNotificationClose = runNotificationCmd "close notification" "close" runNotificationCloseAll :: FeatureX -runNotificationCloseAll = runNotificationCmd "close-all" +runNotificationCloseAll = + runNotificationCmd "close all notifications" "close-all" runNotificationHistory :: FeatureX -runNotificationHistory = runNotificationCmd "history-pop" +runNotificationHistory = + runNotificationCmd "see notification history" "history-pop" runNotificationContext :: FeatureX -runNotificationContext = runNotificationCmd "context" +runNotificationContext = + runNotificationCmd "open notification context" "context" -------------------------------------------------------------------------------- -- | System commands runToggleBluetooth :: FeatureX -runToggleBluetooth = featureRun [exe myBluetooth] $ spawn +runToggleBluetooth = + featureRun "bluetooth toggle" [Executable myBluetooth] + $ spawn $ myBluetooth ++ " show | grep -q \"Powered: no\"" #!&& "a=on" #!|| "a=off" @@ -189,7 +199,8 @@ runToggleBluetooth = featureRun [exe myBluetooth] $ spawn #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" } runToggleEthernet :: FeatureX -runToggleEthernet = featureRun [exe "nmcli"] $ spawn +runToggleEthernet = featureRun "ethernet toggle" [Executable "nmcli"] + $ spawn $ "nmcli -g GENERAL.STATE device show " ++ ethernetIface ++ " | grep -q disconnected" #!&& "a=connect" #!|| "a=disconnect" @@ -197,14 +208,14 @@ runToggleEthernet = featureRun [exe "nmcli"] $ spawn #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" } runStartISyncTimer :: FeatureX -runStartISyncTimer = featureRun [userUnit "mbsync.timer"] +runStartISyncTimer = featureRun "isync timer" [userUnit "mbsync.timer"] $ spawn $ "systemctl --user start mbsync.timer" #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync timer started" } #!|| fmtNotifyCmd defNoteError { body = Just $ Text "Isync timer failed to start" } runStartISyncService :: FeatureX -runStartISyncService = featureRun [userUnit "mbsync.service"] +runStartISyncService = featureRun "isync" [userUnit "mbsync.service"] $ spawn $ "systemctl --user start mbsync.service" #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync completed" } @@ -248,25 +259,26 @@ getCaptureDir = do where fallback = ( ".local/share") <$> getHomeDirectory -runFlameshot :: String -> FeatureX -runFlameshot mode = featureRun [exe myCapture] $ do +runFlameshot :: String -> String -> FeatureX +runFlameshot n mode = featureRun n [Executable myCapture] $ do ssDir <- io getCaptureDir spawnCmd myCapture $ mode : ["-p", ssDir] -- TODO this will steal focus from the current window (and puts it -- in the root window?) ...need to fix runAreaCapture :: FeatureX -runAreaCapture = runFlameshot "gui" +runAreaCapture = runFlameshot "screen area capture" "gui" -- myWindowCap = "screencap -w" --external script runDesktopCapture :: FeatureX -runDesktopCapture = runFlameshot "full" +runDesktopCapture = runFlameshot "fullscreen capture" "full" runScreenCapture :: FeatureX -runScreenCapture = runFlameshot "screen" +runScreenCapture = runFlameshot "screen capture" "screen" runCaptureBrowser :: FeatureX -runCaptureBrowser = featureRun [exe myImageBrowser] $ do +runCaptureBrowser = + featureRun "screen capture browser" [Executable myImageBrowser] $ do dir <- io getCaptureDir spawnCmd myImageBrowser [dir] diff --git a/lib/XMonad/Internal/Command/Power.hs b/lib/XMonad/Internal/Command/Power.hs index bd94c70..367dc08 100644 --- a/lib/XMonad/Internal/Command/Power.hs +++ b/lib/XMonad/Internal/Command/Power.hs @@ -46,11 +46,7 @@ myOptimusManager = "optimus-manager" -- | Core commands runScreenLock :: Feature (X ()) -runScreenLock = Feature - { ftrAction = spawn myScreenlock - , ftrSilent = False - , ftrChildren = [exe myScreenlock] - } +runScreenLock = featureSpawn "screen locker" myScreenlock runPowerOff :: X () runPowerOff = spawn "systemctl poweroff" @@ -105,7 +101,8 @@ runOptimusPrompt' = do #!&& "killall xmonad" runOptimusPrompt :: FeatureX -runOptimusPrompt = featureRun [exe myOptimusManager] runOptimusPrompt' +runOptimusPrompt = featureRun "graphics switcher" [Executable myOptimusManager] + runOptimusPrompt' -------------------------------------------------------------------------------- -- | Universal power prompt diff --git a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs index f8b050c..fa8c165 100644 --- a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs +++ b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs @@ -95,7 +95,7 @@ acpiPath = "/var/run/acpid.socket" -- | Spawn a new thread that will listen for ACPI events on the acpid socket -- and send ClientMessage events when it receives them runPowermon :: FeatureIO -runPowermon = featureRun [pathR acpiPath] listenACPI +runPowermon = featureRun "ACPI event monitor" [pathR acpiPath] listenACPI -- | Handle ClientMessage event containing and ACPI event (to be used in -- Xmonad's event hook) diff --git a/lib/XMonad/Internal/Concurrent/Removable.hs b/lib/XMonad/Internal/Concurrent/Removable.hs index 5888045..7501a0d 100644 --- a/lib/XMonad/Internal/Concurrent/Removable.hs +++ b/lib/XMonad/Internal/Concurrent/Removable.hs @@ -34,13 +34,7 @@ memRemoved :: MemberName memRemoved = memberName_ "InterfacesRemoved" dbusDep :: MemberName -> Dependency -dbusDep m = DBusEndpoint - { ddDbusBus = bus - , ddDbusSystem = True - , ddDbusObject = path - , ddDbusInterface = interface - , ddDbusMember = Signal_ m - } +dbusDep m = DBusEndpoint (Bus True bus) (Endpoint path interface $ Signal_ m) addedDep :: Dependency addedDep = dbusDep memAdded @@ -91,4 +85,5 @@ listenDevices = do $ playSoundMaybe p . f . signalBody runRemovableMon :: FeatureIO -runRemovableMon = featureRun [addedDep, removedDep] listenDevices +runRemovableMon = + featureRun "removeable device monitor" [addedDep, removedDep] listenDevices diff --git a/lib/XMonad/Internal/DBus/Brightness/Common.hs b/lib/XMonad/Internal/DBus/Brightness/Common.hs index f04d7f9..341f2a5 100644 --- a/lib/XMonad/Internal/DBus/Brightness/Common.hs +++ b/lib/XMonad/Internal/DBus/Brightness/Common.hs @@ -8,6 +8,7 @@ module XMonad.Internal.DBus.Brightness.Common , brightnessExporter , callGetBrightness , matchSignal + , signalDep ) where import Control.Monad (void) @@ -16,6 +17,7 @@ import Data.Int (Int32) import DBus import DBus.Client +import qualified DBus.Introspection as I import XMonad.Internal.DBus.Common import XMonad.Internal.Dependency @@ -37,6 +39,7 @@ data BrightnessConfig a b = BrightnessConfig , bcGetMax :: IO a , bcPath :: ObjectPath , bcInterface :: InterfaceName + , bcName :: String } data BrightnessControls = BrightnessControls @@ -47,25 +50,30 @@ data BrightnessControls = BrightnessControls } brightnessControls :: BrightnessConfig a b -> BrightnessControls -brightnessControls BrightnessConfig { bcPath = p, bcInterface = i } = +brightnessControls bc = BrightnessControls - { bctlMax = cb memMax - , bctlMin = cb memMin - , bctlInc = cb memInc - , bctlDec = cb memDec + { bctlMax = cb "max brightness" memMax + , bctlMin = cb "min brightness" memMin + , bctlInc = cb "increase brightness" memInc + , bctlDec = cb "decrease brightness" memDec } where - cb = callBacklight p i + cb = callBacklight bc callGetBrightness :: Num c => BrightnessConfig a b -> IO (Maybe c) callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } = do reply <- callMethod $ methodCall p i memGet return $ reply >>= bodyGetBrightness +signalDep :: BrightnessConfig a b -> Dependency +signalDep BrightnessConfig { bcPath = p, bcInterface = i } = + DBusEndpoint xmonadBus $ Endpoint p i $ Signal_ memCur + matchSignal :: Num c => BrightnessConfig a b -> (Maybe c -> IO ()) -> IO SignalHandler matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = do client <- connectSession addMatch client brMatcher $ cb . bodyGetBrightness . signalBody + -- TODO disconnect here? where brMatcher = matchAny { matchPath = Just p @@ -78,10 +86,11 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = do brightnessExporter :: RealFrac b => [Dependency] -> BrightnessConfig a b -> Client -> FeatureIO -brightnessExporter deps bc client = Feature +brightnessExporter deps bc@BrightnessConfig { bcName = n } client = Feature { ftrAction = exportBrightnessControls' bc client - , ftrSilent = False - , ftrChildren = deps + , ftrName = n ++ " exporter" + , ftrWarning = Default + , ftrChildren = DBusBus xmonadBus:deps } exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> Client -> IO () @@ -98,7 +107,19 @@ exportBrightnessControls' bc client = do , autoMethod' memDec bcDec , autoMethod memGet (round <$> funget maxval :: IO Int32) ] + , interfaceSignals = [sig] } + where + sig = I.Signal + { I.signalName = memCur + , I.signalArgs = + [ + I.SignalArg + { I.signalArgName = "brightness" + , I.signalArgType = TypeInt32 + } + ] + } emitBrightness :: RealFrac b => BrightnessConfig a b -> Client -> b -> IO () emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur = @@ -106,11 +127,12 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur = where sig = signal p i memCur -callBacklight :: ObjectPath -> InterfaceName -> MemberName -> FeatureIO -callBacklight p i m = +callBacklight :: BrightnessConfig a b -> String -> MemberName -> FeatureIO +callBacklight BrightnessConfig { bcPath = p, bcInterface = i, bcName = n } controlName m = Feature { ftrAction = void $ callMethod $ methodCall p i m - , ftrSilent = False + , ftrName = unwords [n, controlName] + , ftrWarning = Default , ftrChildren = [xDbusDep p i $ Method_ m] } diff --git a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs index 0bc278b..cc3984f 100644 --- a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs +++ b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs @@ -6,8 +6,7 @@ module XMonad.Internal.DBus.Brightness.IntelBacklight , matchSignalIB , exportIntelBacklight , intelBacklightControls - , curFileDep - , maxFileDep + , intelBacklightSignalDep , blPath ) where @@ -78,6 +77,7 @@ intelBacklightConfig = BrightnessConfig , bcGetMax = getMaxRawBrightness , bcPath = blPath , bcInterface = interface + , bcName = "Intel backlight" } -------------------------------------------------------------------------------- @@ -89,6 +89,9 @@ curFileDep = pathRW curFile maxFileDep :: Dependency maxFileDep = pathR maxFile +intelBacklightSignalDep :: Dependency +intelBacklightSignalDep = signalDep intelBacklightConfig + exportIntelBacklight :: Client -> FeatureIO exportIntelBacklight = brightnessExporter [curFileDep, maxFileDep] intelBacklightConfig diff --git a/lib/XMonad/Internal/DBus/Common.hs b/lib/XMonad/Internal/DBus/Common.hs index 4394527..b4ca39b 100644 --- a/lib/XMonad/Internal/DBus/Common.hs +++ b/lib/XMonad/Internal/DBus/Common.hs @@ -6,8 +6,9 @@ module XMonad.Internal.DBus.Common , callMethod' , addMatchCallback , xmonadBus + , xmonadBusName , xDbusDep - , initControls + -- , initControls ) where import DBus @@ -15,23 +16,22 @@ import DBus.Client import XMonad.Internal.Dependency -xmonadBus :: BusName -xmonadBus = busName_ "org.xmonad" +xmonadBusName :: BusName +xmonadBusName = busName_ "org.xmonad" + +xmonadBus :: Bus +xmonadBus = Bus False xmonadBusName xDbusDep :: ObjectPath -> InterfaceName -> DBusMember -> Dependency -xDbusDep o i m = DBusEndpoint - { ddDbusBus = xmonadBus - , ddDbusSystem = False - , ddDbusObject = o - , ddDbusInterface = i - , ddDbusMember = m - } +xDbusDep o i m = DBusEndpoint xmonadBus $ Endpoint o i m + +-- connectBus :: Bus -> IO (Maybe Client) -- | Call a method and return its result if successful callMethod :: MethodCall -> IO (Maybe [Variant]) callMethod mc = do client <- connectSession - r <- callMethod' client (Just xmonadBus) mc + r <- callMethod' client (Just xmonadBusName) mc disconnect client return r @@ -50,11 +50,11 @@ addMatchCallback rule cb = do client <- connectSession addMatch client rule $ cb . signalBody -initControls :: Client -> (Client -> FeatureIO) -> (FeatureIO -> a) -> IO a -initControls client exporter controls = do - let x = exporter client - e <- evalFeature x - case e of - (Right c) -> c - _ -> return () - return $ controls x +-- initControls :: Client -> (Client -> FeatureIO) -> (FeatureIO -> a) -> IO a +-- initControls client exporter controls = do +-- let x = exporter client +-- e <- evalFeature x +-- case e of +-- (Right c) -> c +-- _ -> return () +-- return $ controls x diff --git a/lib/XMonad/Internal/DBus/Control.hs b/lib/XMonad/Internal/DBus/Control.hs index 4ac3654..159157f 100644 --- a/lib/XMonad/Internal/DBus/Control.hs +++ b/lib/XMonad/Internal/DBus/Control.hs @@ -19,7 +19,6 @@ import Data.Either import DBus import DBus.Client --- import XMonad.Internal.DBus.Brightness.Common import XMonad.Internal.DBus.Brightness.IntelBacklight import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Screensaver @@ -42,7 +41,7 @@ startXMonadService = do stopXMonadService :: Client -> IO () stopXMonadService client = do - void $ releaseName client xmonadBus + void $ releaseName client xmonadBusName disconnect client getDBusClient :: IO (Maybe Client) @@ -54,7 +53,7 @@ getDBusClient = do requestXMonadName :: Client -> IO () requestXMonadName client = do - res <- requestName client xmonadBus [] + res <- requestName client xmonadBusName [] -- TODO if the client is not released on shutdown the owner will be -- different let msg | res == NamePrimaryOwner = Nothing @@ -64,7 +63,7 @@ requestXMonadName client = do | otherwise = Just $ "unknown error when requesting " ++ xn forM_ msg putStrLn where - xn = "'" ++ formatBusName xmonadBus ++ "'" + xn = "'" ++ formatBusName xmonadBusName ++ "'" pathExists :: Bool -> BusName -> ObjectPath -> IO Bool pathExists sysbus n p = do diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index f2a6fda..aa04b28 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/lib/XMonad/Internal/DBus/Screensaver.hs @@ -8,6 +8,7 @@ module XMonad.Internal.DBus.Screensaver , matchSignal , ssPath , ssDep + , ssSignalDep , SSControls(..) ) where @@ -15,6 +16,7 @@ import Control.Monad (void) import DBus import DBus.Client +import qualified DBus.Introspection as I import Graphics.X11.XScreenSaver import Graphics.X11.Xlib.Display @@ -34,6 +36,10 @@ ssExecutable = "xset" ssDep :: Dependency ssDep = Executable ssExecutable +ssSignalDep :: Dependency +ssSignalDep = DBusEndpoint xmonadBus $ Endpoint ssPath interface + $ Signal_ memState + toggle :: IO SSState toggle = do st <- query @@ -99,16 +105,12 @@ bodyGetCurrentState _ = Nothing newtype SSControls = SSControls { ssToggle :: FeatureIO } --- exportScreensaver :: Client -> IO SSControls --- exportScreensaver client = initControls client exportScreensaver' controls --- where --- controls _ = SSControls { ssToggle = callToggle } - exportScreensaver :: Client -> FeatureIO exportScreensaver client = Feature { ftrAction = cmd - , ftrSilent = False - , ftrChildren = [ssDep] + , ftrName = "screensaver interface" + , ftrWarning = Default + , ftrChildren = [ssDep, DBusBus xmonadBus] } where cmd = export client ssPath defaultInterface @@ -117,12 +119,24 @@ exportScreensaver client = Feature [ autoMethod memToggle $ emitState client =<< toggle , autoMethod memQuery query ] + , interfaceSignals = [sig] + } + sig = I.Signal + { I.signalName = memState + , I.signalArgs = + [ + I.SignalArg + { I.signalArgName = "enabled" + , I.signalArgType = TypeBoolean + } + ] } callToggle :: FeatureIO callToggle = Feature { ftrAction = cmd - , ftrSilent = False + , ftrName = "screensaver toggle" + , ftrWarning = Default , ftrChildren = [xDbusDep ssPath interface $ Method_ memToggle] } where diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index 8937fa4..32f4cd5 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/lib/XMonad/Internal/Dependency.hs @@ -5,14 +5,16 @@ module XMonad.Internal.Dependency ( MaybeExe , UnitType(..) , Dependency(..) + , Bus(..) + , Endpoint(..) , DBusMember(..) + , Warning(..) , MaybeX , FeatureX , FeatureIO , Feature(..) , ioFeature , evalFeature - , exe , systemUnit , userUnit , pathR @@ -34,14 +36,16 @@ module XMonad.Internal.Dependency import Control.Monad.IO.Class +import Data.Bifunctor (bimap) import Data.List (find) -import Data.Maybe (listToMaybe, maybeToList) +import Data.Maybe (catMaybes, fromMaybe, listToMaybe) import DBus import DBus.Client import qualified DBus.Introspection as I import System.Directory (findExecutable, readable, writable) +import System.Environment import System.Exit import XMonad.Core (X, io) @@ -59,21 +63,23 @@ data DBusMember = Method_ MemberName | Property_ String deriving (Eq, Show) +data Bus = Bus Bool BusName deriving (Eq, Show) + +data Endpoint = Endpoint ObjectPath InterfaceName DBusMember deriving (Eq, Show) + data Dependency = Executable String | AccessiblePath FilePath Bool Bool | IOTest (IO (Maybe String)) - | DBusEndpoint - { ddDbusBus :: BusName - , ddDbusSystem :: Bool - , ddDbusObject :: ObjectPath - , ddDbusInterface :: InterfaceName - , ddDbusMember :: DBusMember - } + | DBusEndpoint Bus Endpoint + | DBusBus Bus | Systemd UnitType String +data Warning = Silent | Default + data Feature a = Feature { ftrAction :: a - , ftrSilent :: Bool + , ftrName :: String + , ftrWarning :: Warning , ftrChildren :: [Dependency] } | ConstFeature a @@ -91,16 +97,21 @@ ioFeature BlankFeature = BlankFeature evalFeature :: Feature a -> IO (MaybeExe a) evalFeature (ConstFeature x) = return $ Right x evalFeature BlankFeature = return $ Left [] -evalFeature Feature { ftrAction = a, ftrSilent = s, ftrChildren = c } = do - es <- mapM go c - return $ case concat es of +evalFeature Feature + { ftrAction = a + , ftrName = n + , ftrWarning = w + , ftrChildren = c + } = do + procName <- getProgName + es <- catMaybes <$> mapM evalDependency c + return $ case es of [] -> Right a - es' -> Left (if s then [] else es') + es' -> Left $ fmtWarnings procName es' where - go = fmap maybeToList . depInstalled - -exe :: String -> Dependency -exe = Executable + fmtWarnings procName es = case w of + Silent -> [] + Default -> fmap (fmtMsg procName "WARNING" . ((n ++ " disabled; ") ++)) es pathR :: String -> Dependency pathR n = AccessiblePath n True False @@ -123,18 +134,19 @@ type MaybeExe a = Either [String] a type MaybeX = MaybeExe (X ()) -featureRun :: [Dependency] -> a -> Feature a -featureRun ds x = Feature +featureRun :: String -> [Dependency] -> a -> Feature a +featureRun n ds x = Feature { ftrAction = x - , ftrSilent = False + , ftrName = n + , ftrWarning = Default , ftrChildren = ds } -featureSpawnCmd :: MonadIO m => String -> [String] -> Feature (m ()) -featureSpawnCmd cmd args = featureRun [exe cmd] $ spawnCmd cmd args +featureSpawnCmd :: MonadIO m => String -> String -> [String] -> Feature (m ()) +featureSpawnCmd n cmd args = featureRun n [Executable cmd] $ spawnCmd cmd args -featureSpawn :: MonadIO m => String -> Feature (m ()) -featureSpawn cmd = featureSpawnCmd cmd [] +featureSpawn :: MonadIO m => String -> String -> Feature (m ()) +featureSpawn n cmd = featureSpawnCmd n cmd [] exeInstalled :: String -> IO (Maybe String) exeInstalled x = do @@ -177,37 +189,69 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable" introspectMethod :: MemberName introspectMethod = memberName_ "Introspect" -dbusInstalled :: BusName -> Bool -> ObjectPath -> InterfaceName -> DBusMember - -> IO (Maybe String) -dbusInstalled bus usesystem objpath iface mem = do - client <- if usesystem then connectSystem else connectSession - reply <- call_ client (methodCall objpath introspectInterface introspectMethod) +callMethod :: Bus -> ObjectPath -> InterfaceName -> MemberName -> IO (Either String [Variant]) +callMethod (Bus usesys bus) path iface mem = do + client <- if usesys then connectSystem else connectSession + reply <- call client (methodCall path iface mem) { methodCallDestination = Just bus } - let res = findMem =<< I.parseXML objpath =<< fromVariant - =<< listToMaybe (methodReturnBody reply) disconnect client - return $ case res of - Just _ -> Nothing - _ -> Just "some random dbus interface not found" - where - findMem obj = fmap (matchMem mem) - $ find (\i -> I.interfaceName i == iface) - $ I.objectInterfaces obj - matchMem (Method_ n) = elem n . fmap I.methodName . I.interfaceMethods - matchMem (Signal_ n) = elem n . fmap I.signalName . I.interfaceSignals - matchMem (Property_ n) = elem n . fmap I.propertyName . I.interfaceProperties + return $ bimap methodErrorMessage methodReturnBody reply -depInstalled :: Dependency -> IO (Maybe String) -depInstalled (Executable n) = exeInstalled n -depInstalled (IOTest t) = t -depInstalled (Systemd t n) = unitInstalled t n -depInstalled (AccessiblePath p r w) = pathAccessible p r w -depInstalled DBusEndpoint { ddDbusBus = b - , ddDbusSystem = s - , ddDbusObject = o - , ddDbusInterface = i - , ddDbusMember = m - } = dbusInstalled b s o i m +dbusBusExists :: Bus -> IO (Maybe String) +dbusBusExists (Bus usesystem bus) = do + ret <- callMethod (Bus usesystem queryBus) queryPath queryIface queryMem + return $ case ret of + Left e -> Just e + Right b -> let ns = bodyGetNames b in + if bus' `elem` ns then Nothing + else Just $ unwords ["name", singleQuote bus', "not found on dbus"] + where + bus' = formatBusName bus + queryBus = busName_ "org.freedesktop.DBus" + queryIface = interfaceName_ "org.freedesktop.DBus" + queryPath = objectPath_ "/" + queryMem = memberName_ "ListNames" + bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String] + bodyGetNames _ = [] + +dbusEndpointExists :: Bus -> Endpoint -> IO (Maybe String) +dbusEndpointExists b@(Bus _ bus) (Endpoint objpath iface mem) = do + ret <- callMethod b objpath introspectInterface introspectMethod + return $ case ret of + Left e -> Just e + Right body -> procBody body + where + procBody body = let res = findMem =<< I.parseXML objpath =<< fromVariant + =<< listToMaybe body in + case res of + Just True -> Nothing + _ -> Just $ fmtMsg' mem + findMem = fmap (matchMem mem) + . find (\i -> I.interfaceName i == iface) + . I.objectInterfaces + matchMem (Method_ n) = elemMember n I.methodName I.interfaceMethods + matchMem (Signal_ n) = elemMember n I.signalName I.interfaceSignals + matchMem (Property_ n) = elemMember n I.propertyName I.interfaceProperties + elemMember n fname fmember = elem n . fmap fname . fmember + fmtMem (Method_ n) = "method " ++ singleQuote (formatMemberName n) + fmtMem (Signal_ n) = "signal " ++ singleQuote (formatMemberName n) + fmtMem (Property_ n) = "property " ++ singleQuote n + fmtMsg' m = unwords + [ "could not find" + , fmtMem m + , "on interface" + , singleQuote $ formatInterfaceName iface + , "on bus" + , formatBusName bus + ] + +evalDependency :: Dependency -> IO (Maybe String) +evalDependency (Executable n) = exeInstalled n +evalDependency (IOTest t) = t +evalDependency (Systemd t n) = unitInstalled t n +evalDependency (AccessiblePath p r w) = pathAccessible p r w +evalDependency (DBusEndpoint b e) = dbusEndpointExists b e +evalDependency (DBusBus b) = dbusBusExists b whenInstalled :: Monad m => MaybeExe (m ()) -> m () whenInstalled = flip ifInstalled skip @@ -217,7 +261,7 @@ ifInstalled (Right x) _ = x ifInstalled _ alt = alt warnMissing :: [MaybeExe a] -> IO () -warnMissing xs = warnMissing' $ fmap ("[WARNING] "++) $ concat $ [ m | (Left m) <- xs ] +warnMissing xs = warnMissing' $ concat $ [ m | (Left m) <- xs ] warnMissing' :: [String] -> IO () warnMissing' = mapM_ putStrLn @@ -235,3 +279,9 @@ executeFeature = applyFeature id executeFeature_ :: Feature (IO ()) -> IO () executeFeature_ = executeFeature () + +fmtMsg :: String -> String -> String -> String +fmtMsg procName level msg = unwords [bracket procName, bracket level, msg] + where + bracket s = "[" ++ s ++ "]" +