From 23098420aa5658914c05bd5db0eec2bc3f7084af Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 8 Nov 2021 00:27:39 -0500 Subject: [PATCH] WIP use DBus dependency API everywhere --- bin/xmobar.hs | 30 ++++++++++++++++--- bin/xmonad.hs | 17 ++++------- lib/XMonad/Internal/DBus/Brightness/Common.hs | 11 ++++--- lib/XMonad/Internal/DBus/Control.hs | 7 +++-- lib/XMonad/Internal/DBus/Screensaver.hs | 18 +++++------ lib/XMonad/Internal/Dependency.hs | 30 +++++++++++-------- lib/Xmobar/Plugins/Bluetooth.hs | 12 +++++++- 7 files changed, 78 insertions(+), 47 deletions(-) diff --git a/bin/xmobar.hs b/bin/xmobar.hs index 1b3b319..5a777dc 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -42,7 +42,8 @@ import XMonad.Internal.DBus.Brightness.IntelBacklight (blPath) import XMonad.Internal.DBus.Common (xmonadBus) import XMonad.Internal.DBus.Control (pathExists) import XMonad.Internal.DBus.Screensaver (ssPath) -import XMonad.Internal.Shell (fmtCmd) +import XMonad.Internal.Dependency +-- import XMonad.Internal.Shell (fmtCmd) import qualified XMonad.Internal.Theme as T import Xmobar @@ -226,6 +227,19 @@ toJust x b = if b then Just x else Nothing whenDBusPath :: Bool -> BusName -> ObjectPath -> CmdSpec -> IO (Maybe CmdSpec) whenDBusPath usesys b p cs = toJust cs <$> pathExists usesys b p +dbusDep :: Bool -> BusName -> ObjectPath -> InterfaceName -> DBusMember -> Dependency +dbusDep usesys bus obj iface mem = + Dependency { depRequired = True, depData = d } + where + d = DBusEndpoint + { ddDbusBus = bus + , ddDbusSystem = usesys + , ddDbusObject = obj + , ddDbusInterface = iface + , ddDbusMember = mem + } + + -- in the case of network interfaces, assume that the system uses systemd in -- which case ethernet interfaces always start with "en" and wireless -- interfaces always start with "wl" @@ -275,8 +289,11 @@ getVPN = do where args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"] -getBt :: IO (Maybe CmdSpec) -getBt = whenDBusPath True btBus btPath btCmd +getBt :: IO (MaybeExe CmdSpec) +-- getBt = whenDBusPath True btBus btPath btCmd +getBt = runIfInstalled [dep] btCmd + where + dep = dbusDep True btBus btPath btInterface $ Property_ btPowered getAlsa :: IO (Maybe CmdSpec) getAlsa = toJust alsaCmd . isJust <$> findExecutable "alsactl" @@ -289,6 +306,10 @@ getSs = whenDBusPath False xmonadBus ssPath ssCmd getAllCommands :: IO BarRegions getAllCommands = do + getBt' <- getBt + let bt = case getBt' of + (Installed x _) -> Just x + _ -> Nothing let left = [ CmdSpec { csAlias = "UnsafeStdinReader" @@ -299,7 +320,8 @@ getAllCommands = do [ getWireless , getEthernet , getVPN - , getBt + -- , getBt + , return bt , getAlsa , getBattery , getBl diff --git a/bin/xmonad.hs b/bin/xmonad.hs index 6d9555d..81c20f1 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -73,10 +73,8 @@ main = do , dxScreensaverCtrl = sc } <- startXMonadService (h, p) <- spawnPipe "xmobar" - powermonAction <- runPowermon - removableAction <- runRemovableMon - mapM_ forkIO powermonAction - mapM_ forkIO removableAction + depActions <- sequence [runPowermon, runRemovableMon] + mapM_ (mapM_ forkIO) depActions _ <- forkIO $ runWorkspaceMon allDWs let ts = ThreadState { client = cl @@ -84,13 +82,12 @@ main = do , childHandles = [h] } ext <- evalExternal $ externalBindings bc sc ts - let ekbs = filterExternal ext - warnMissing $ externalToMissing ext ++ fmap (fmap io) [powermonAction, removableAction] + warnMissing $ externalToMissing ext ++ fmap (io <$>) depActions -- IDK why this is necessary; nothing prior to this line will print if missing hFlush stdout launch $ ewmh - $ addKeymap ekbs + $ addKeymap (filterExternal ext) $ def { terminal = myTerm , modMask = myModMask , layoutHook = myLayouts @@ -507,9 +504,7 @@ flagKeyBinding k@KeyBinding{ kbDesc = d, kbAction = a } = case a of Missing _ _ -> Just $ k{ kbDesc = "[!!!]" ++ d, kbAction = skip } Ignore -> Nothing -externalBindings :: BrightnessControls - -> MaybeExe SSControls - -> ThreadState +externalBindings :: BrightnessControls -> SSControls -> ThreadState -> [KeyGroup (IO MaybeX)] externalBindings bc sc ts = [ KeyGroup "Launchers" @@ -571,7 +566,7 @@ externalBindings bc sc ts = , KeyBinding "M-" "select autorandr profile" runAutorandrMenu , KeyBinding "M-" "toggle ethernet" runToggleEthernet , KeyBinding "M-" "toggle bluetooth" runToggleBluetooth - , KeyBinding "M-" "toggle screensaver" $ return $ fmap (io . ssToggle) sc + , KeyBinding "M-" "toggle screensaver" $ return $ io <$> ssToggle sc , KeyBinding "M-" "switch gpu" runOptimusPrompt ] ] diff --git a/lib/XMonad/Internal/DBus/Brightness/Common.hs b/lib/XMonad/Internal/DBus/Brightness/Common.hs index fa6e35c..c7e1db2 100644 --- a/lib/XMonad/Internal/DBus/Brightness/Common.hs +++ b/lib/XMonad/Internal/DBus/Brightness/Common.hs @@ -49,16 +49,15 @@ exportBrightnessControls :: RealFrac b => [Dependency] -> BrightnessConfig a b -> Client -> IO BrightnessControls exportBrightnessControls deps bc client = do (req, opt) <- checkInstalled deps + let callBacklight' = createInstalled req opt . callBacklight bc when (null req) $ exportBrightnessControls' bc client return $ BrightnessControls - { bctlMax = callBacklight' req opt memMax - , bctlMin = callBacklight' req opt memMin - , bctlInc = callBacklight' req opt memInc - , bctlDec = callBacklight' req opt memDec + { bctlMax = callBacklight' memMax + , bctlMin = callBacklight' memMin + , bctlInc = callBacklight' memInc + , bctlDec = callBacklight' memDec } - where - callBacklight' r o = createInstalled r o . callBacklight bc callGetBrightness :: Num c => BrightnessConfig a b -> IO (Maybe c) callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } = do diff --git a/lib/XMonad/Internal/DBus/Control.hs b/lib/XMonad/Internal/DBus/Control.hs index ef233f6..ed61f85 100644 --- a/lib/XMonad/Internal/DBus/Control.hs +++ b/lib/XMonad/Internal/DBus/Control.hs @@ -33,7 +33,7 @@ data DBusXMonad = DBusXMonad { dxClient :: Client , dxIntelBacklightCtrl :: BrightnessControls -- , dxClevoBacklightCtrl :: MaybeExe BrightnessControls - , dxScreensaverCtrl :: MaybeExe SSControls + , dxScreensaverCtrl :: SSControls } blankControls :: BrightnessControls @@ -44,6 +44,9 @@ blankControls = BrightnessControls , bctlDec = Ignore } +blankSSToggle :: SSControls +blankSSToggle = SSControls { ssToggle = Ignore } + startXMonadService :: IO DBusXMonad startXMonadService = do client <- connectSession @@ -52,7 +55,7 @@ startXMonadService = do -- different (i, s) <- if requestResult /= NamePrimaryOwner then do putStrLn "Another service owns \"org.xmonad\"" - return (blankControls, Ignore) + return (blankControls, blankSSToggle) else do putStrLn "Started xmonad dbus client" bc <- exportIntelBacklight client diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index a1b690d..95c5312 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/lib/XMonad/Internal/DBus/Screensaver.hs @@ -10,7 +10,7 @@ module XMonad.Internal.DBus.Screensaver , SSControls(..) ) where -import Control.Monad (void) +import Control.Monad (void, when) import DBus import DBus.Client @@ -90,17 +90,16 @@ bodyGetCurrentState _ = Nothing -------------------------------------------------------------------------------- -- | Exported haskell API -newtype SSControls = SSControls { ssToggle :: IO () } +newtype SSControls = SSControls { ssToggle :: MaybeExe (IO ()) } -exportScreensaver :: Client -> IO (MaybeExe SSControls) +exportScreensaver :: Client -> IO SSControls exportScreensaver client = do - d <- depInstalled $ depData dep - if d then flip Installed [] <$> exportScreensaver' client - else return $ Missing [depData dep] [] - where - dep = exe "xset" + (req, opt) <- checkInstalled [exe "xset"] + when (null req) $ + exportScreensaver' client + return $ SSControls { ssToggle = createInstalled req opt callToggle } -exportScreensaver' :: Client -> IO SSControls +exportScreensaver' :: Client -> IO () exportScreensaver' client = do export client ssPath defaultInterface { interfaceName = interface @@ -109,7 +108,6 @@ exportScreensaver' client = do , autoMethod memQuery query ] } - return $ SSControls { ssToggle = callToggle } callToggle :: IO () callToggle = void $ callMethod $ methodCall ssPath interface memToggle diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index 94977f3..be79041 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/lib/XMonad/Internal/Dependency.hs @@ -42,12 +42,12 @@ import Control.Arrow ((***)) import Control.Monad (filterM, join) import Control.Monad.IO.Class -import Data.List (partition, find) -import Data.Maybe (isJust, listToMaybe, fromMaybe) +import Data.List (find, partition) +import Data.Maybe (fromMaybe, isJust, listToMaybe) import DBus import DBus.Client -import qualified DBus.Introspection as I +import qualified DBus.Introspection as I import System.Directory (findExecutable, readable, writable) import System.Exit @@ -71,11 +71,11 @@ data DBusMember = Method_ MemberName data DependencyData = Executable String | AccessiblePath FilePath Bool Bool | DBusEndpoint - { ddDbusBus:: BusName - , ddDbusSystem :: Bool - , ddDbusObject :: ObjectPath + { ddDbusBus :: BusName + , ddDbusSystem :: Bool + , ddDbusObject :: ObjectPath , ddDbusInterface :: InterfaceName - , ddDbusMember :: DBusMember + , ddDbusMember :: DBusMember } | Systemd UnitType String deriving (Eq, Show) @@ -174,15 +174,18 @@ pathAccessible p testread testwrite = do -- (_, Just False) -> Just "file not writable" -- _ -> Nothing +introspectInterface :: InterfaceName +introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable" + +introspectMethod :: MemberName +introspectMethod = memberName_ "Introspect" + dbusInstalled :: BusName -> Bool -> ObjectPath -> InterfaceName -> DBusMember -> IO Bool dbusInstalled bus usesystem objpath iface mem = do client <- if usesystem then connectSystem else connectSession - reply <- call_ client (methodCall objpath - (interfaceName_ "org.freedesktop.DBus.Introspectable") - (memberName_ "Introspect")) - { methodCallDestination = Just bus - } + reply <- call_ client (methodCall objpath introspectInterface introspectMethod) + { methodCallDestination = Just bus } let res = findMem =<< I.parseXML objpath =<< fromVariant =<< listToMaybe (methodReturnBody reply) disconnect client @@ -218,7 +221,8 @@ createInstalled req opt x = if null req then Installed x opt else Missing req op filterMissing :: [Dependency] -> IO [Dependency] filterMissing = filterM (fmap not . depInstalled . depData) -runIfInstalled :: MonadIO m => [Dependency] -> m a -> IO (MaybeExe (m a)) +-- runIfInstalled :: MonadIO m => [Dependency] -> m a -> IO (MaybeExe (m a)) +runIfInstalled :: [Dependency] -> a -> IO (MaybeExe a) runIfInstalled ds x = do (req, opt) <- checkInstalled ds return $ createInstalled req opt x diff --git a/lib/Xmobar/Plugins/Bluetooth.hs b/lib/Xmobar/Plugins/Bluetooth.hs index f997899..f762a7d 100644 --- a/lib/Xmobar/Plugins/Bluetooth.hs +++ b/lib/Xmobar/Plugins/Bluetooth.hs @@ -11,6 +11,8 @@ module Xmobar.Plugins.Bluetooth , btAlias , btBus , btPath + , btPowered + , btInterface ) where import DBus @@ -24,9 +26,17 @@ data Bluetooth = Bluetooth (String, String, String) Int callGetPowered :: Client -> IO (Either MethodError Variant) callGetPowered client = - getProperty client (methodCall btPath "org.bluez.Adapter1" "Powered") + getProperty client (methodCall btPath btInterface $ memberName_ btPowered) { methodCallDestination = Just btBus } +btInterface :: InterfaceName +btInterface = "org.bluez.Adapter1" + +-- weird that this is a string when introspecting but a member name when calling +-- a method, not sure if it is supposed to work like that +btPowered :: String +btPowered = "Powered" + btBus :: BusName btBus = "org.bluez"