From fd372200059dd9cd919f2d79e3dd260d1403c7ed Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sat, 27 Nov 2021 01:02:22 -0500 Subject: [PATCH] REF move all 'common' DBus code to seperate shared module --- bin/xmobar.hs | 2 +- lib/DBus/Internal.hs | 170 ++++++++++++++++++ lib/XMonad/Internal/DBus/Brightness/Common.hs | 1 + lib/XMonad/Internal/DBus/Common.hs | 94 +--------- lib/XMonad/Internal/DBus/Control.hs | 19 +- lib/XMonad/Internal/DBus/Screensaver.hs | 1 + lib/XMonad/Internal/Dependency.hs | 74 +------- lib/Xmobar/Plugins/Bluetooth.hs | 4 +- lib/Xmobar/Plugins/Common.hs | 4 +- lib/Xmobar/Plugins/Device.hs | 2 +- lib/Xmobar/Plugins/VPN.hs | 2 +- my-xmonad.cabal | 3 +- 12 files changed, 190 insertions(+), 186 deletions(-) create mode 100644 lib/DBus/Internal.hs diff --git a/bin/xmobar.hs b/bin/xmobar.hs index 94e819c..363847a 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -18,6 +18,7 @@ import Data.List import Data.Maybe import DBus.Client +import DBus.Internal import System.Directory import System.Exit @@ -42,7 +43,6 @@ import XMonad.Hooks.DynamicLog import XMonad.Internal.Command.Power (hasBattery) import XMonad.Internal.DBus.Brightness.ClevoKeyboard import XMonad.Internal.DBus.Brightness.IntelBacklight -import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Screensaver (ssSignalDep) import XMonad.Internal.Dependency import XMonad.Internal.Shell diff --git a/lib/DBus/Internal.hs b/lib/DBus/Internal.hs new file mode 100644 index 0000000..9f033be --- /dev/null +++ b/lib/DBus/Internal.hs @@ -0,0 +1,170 @@ +-------------------------------------------------------------------------------- +-- | Common internal DBus functions + +module DBus.Internal + ( addMatchCallback + , getDBusClient + , withDBusClient + , withDBusClient_ + , matchProperty + , matchProperty' + , matchPropertyChanged + , SignalMatch(..) + , SignalCallback + , MethodBody + , withSignalMatch + , callPropertyGet + , callMethod + , callMethod' + , callGetManagedObjects + , ObjectTree + , getManagedObjects + , omInterface + , addInterfaceAddedListener + , addInterfaceRemovedListener + ) where + +import Control.Exception +import Control.Monad + +import Data.Bifunctor +import qualified Data.Map.Strict as M +import Data.Maybe + +import DBus +import DBus.Client + +-------------------------------------------------------------------------------- +-- | Methods + +type MethodBody = Either String [Variant] + +callMethod' :: Client -> MethodCall -> IO MethodBody +callMethod' cl = fmap (bimap methodErrorMessage methodReturnBody) . call cl + +callMethod :: Client -> BusName -> ObjectPath -> InterfaceName -> MemberName + -> IO MethodBody +callMethod client bus path iface mem = + callMethod' client (methodCall path iface mem) + { methodCallDestination = Just bus } + +-------------------------------------------------------------------------------- +-- | Signals + +type SignalCallback = [Variant] -> IO () + +addMatchCallback :: MatchRule -> SignalCallback -> Client -> IO SignalHandler +addMatchCallback rule cb client = addMatch client rule $ cb . signalBody + +-------------------------------------------------------------------------------- +-- | Properties + +propertyInterface :: InterfaceName +propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties" + +propertySignal :: MemberName +propertySignal = memberName_ "PropertiesChanged" + +callPropertyGet :: BusName -> ObjectPath -> InterfaceName -> String -> Client + -> IO [Variant] +callPropertyGet bus path iface property client = either (const []) (:[]) + <$> getProperty client (methodCall path iface $ memberName_ property) + { methodCallDestination = Just bus } + +-- TODO actually get the real busname when using this (will involve IO) +matchProperty' :: Maybe ObjectPath -> MatchRule +matchProperty' p = matchAny + -- NOTE: the sender for signals is usually the unique name (eg :X.Y) not the + -- requested name (eg "org.something.understandable"). If sender is included + -- here, likely nothing will match. Solution is to somehow get the unique + -- name, which I could do, but probably won't + { matchPath = p + , matchInterface = Just propertyInterface + , matchMember = Just propertySignal + } + +matchProperty :: ObjectPath -> MatchRule +matchProperty = matchProperty' . Just + +data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show) + +withSignalMatch :: (Maybe a -> IO ()) -> SignalMatch a -> IO () +withSignalMatch f (Match x) = f (Just x) +withSignalMatch f Failure = f Nothing +withSignalMatch _ NoMatch = return () + +matchPropertyChanged :: IsVariant a => InterfaceName -> String -> [Variant] + -> SignalMatch a +matchPropertyChanged iface property [i, body, _] = + let i' = (fromVariant i :: Maybe String) + b = toMap body in + case (i', b) of + (Just i'', Just b') -> if i'' == formatInterfaceName iface then + maybe NoMatch Match $ fromVariant =<< M.lookup property b' + else NoMatch + _ -> Failure + where + toMap v = fromVariant v :: Maybe (M.Map String Variant) +matchPropertyChanged _ _ _ = Failure + +-------------------------------------------------------------------------------- +-- | Client requests + +getDBusClient :: Bool -> IO (Maybe Client) +getDBusClient sys = do + res <- try $ if sys then connectSystem else connectSession + case res of + Left e -> putStrLn (clientErrorMessage e) >> return Nothing + Right c -> return $ Just c + +withDBusClient :: Bool -> (Client -> a) -> IO (Maybe a) +withDBusClient sys f = do + client <- getDBusClient sys + let r = f <$> client + mapM_ disconnect client + return r + +withDBusClient_ :: Bool -> (Client -> IO ()) -> IO () +withDBusClient_ sys f = do + client <- getDBusClient sys + mapM_ f client + mapM_ disconnect client + +-------------------------------------------------------------------------------- +-- | Object Manager + +type ObjectTree = M.Map ObjectPath (M.Map String (M.Map String Variant)) + +omInterface :: InterfaceName +omInterface = interfaceName_ "org.freedesktop.DBus.ObjectManager" + +getManagedObjects :: MemberName +getManagedObjects = memberName_ "GetManagedObjects" + +callGetManagedObjects :: Client -> BusName -> ObjectPath -> IO ObjectTree +callGetManagedObjects client bus path = + either (const M.empty) (fromMaybe M.empty . (fromVariant <=< listToMaybe)) + <$> callMethod client bus path omInterface getManagedObjects + +omInterfacesAdded :: MemberName +omInterfacesAdded = memberName_ "InterfacesAdded" + +omInterfacesRemoved :: MemberName +omInterfacesRemoved = memberName_ "InterfacesRemoved" + +-- TODO add busname back to this (use NameGetOwner on org.freedesktop.DBus) +addInterfaceChangedListener :: MemberName -> ObjectPath -> SignalCallback + -> Client -> IO () +addInterfaceChangedListener prop path = fmap void . addMatchCallback rule + where + rule = matchAny + { matchPath = Just path + , matchInterface = Just omInterface + , matchMember = Just prop + } + +addInterfaceAddedListener :: ObjectPath -> SignalCallback -> Client -> IO () +addInterfaceAddedListener = addInterfaceChangedListener omInterfacesAdded + +addInterfaceRemovedListener :: ObjectPath -> SignalCallback -> Client -> IO () +addInterfaceRemovedListener = addInterfaceChangedListener omInterfacesRemoved diff --git a/lib/XMonad/Internal/DBus/Brightness/Common.hs b/lib/XMonad/Internal/DBus/Brightness/Common.hs index 7242830..ff2d2fc 100644 --- a/lib/XMonad/Internal/DBus/Brightness/Common.hs +++ b/lib/XMonad/Internal/DBus/Brightness/Common.hs @@ -17,6 +17,7 @@ import Data.Int (Int32) import DBus import DBus.Client +import DBus.Internal import qualified DBus.Introspection as I import XMonad.Internal.DBus.Common diff --git a/lib/XMonad/Internal/DBus/Common.hs b/lib/XMonad/Internal/DBus/Common.hs index 89ef398..f4d707c 100644 --- a/lib/XMonad/Internal/DBus/Common.hs +++ b/lib/XMonad/Internal/DBus/Common.hs @@ -1,101 +1,11 @@ -------------------------------------------------------------------------------- --- | Common internal DBus functions +-- | High-level interface for managing XMonad's DBus module XMonad.Internal.DBus.Common - ( addMatchCallback - , getDBusClient - , withDBusClient - , withDBusClient_ - , matchProperty - , matchProperty' - , xmonadBusName - , matchPropertyChanged - , SignalMatch(..) - , SignalCallback - , withSignalMatch - , callPropertyGet + ( xmonadBusName ) where -import Control.Exception - -import qualified Data.Map.Strict as M - import DBus -import DBus.Client xmonadBusName :: BusName xmonadBusName = busName_ "org.xmonad" - -type SignalCallback = [Variant] -> IO () - --- | Bind a callback to a signal match rule -addMatchCallback :: MatchRule -> SignalCallback -> Client -> IO SignalHandler -addMatchCallback rule cb client = addMatch client rule $ cb . signalBody - -getDBusClient :: Bool -> IO (Maybe Client) -getDBusClient sys = do - res <- try $ if sys then connectSystem else connectSession - case res of - Left e -> putStrLn (clientErrorMessage e) >> return Nothing - Right c -> return $ Just c - -withDBusClient :: Bool -> (Client -> a) -> IO (Maybe a) -withDBusClient sys f = do - client <- getDBusClient sys - let r = f <$> client - mapM_ disconnect client - return r - -withDBusClient_ :: Bool -> (Client -> IO ()) -> IO () -withDBusClient_ sys f = do - client <- getDBusClient sys - mapM_ f client - mapM_ disconnect client - -propertyInterface :: InterfaceName -propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties" - -propertySignal :: MemberName -propertySignal = memberName_ "PropertiesChanged" - -matchProperty' :: Maybe ObjectPath -> MatchRule -matchProperty' p = matchAny - -- NOTE: the sender for signals is usually the unique name (eg :X.Y) not the - -- requested name (eg "org.something.understandable"). If sender is included - -- here, likely nothing will match. Solution is to somehow get the unique - -- name, which I could do, but probably won't - { matchPath = p - , matchInterface = Just propertyInterface - , matchMember = Just propertySignal - } - -matchProperty :: ObjectPath -> MatchRule -matchProperty = matchProperty' . Just - -data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show) - -withSignalMatch :: (Maybe a -> IO ()) -> SignalMatch a -> IO () -withSignalMatch f (Match x) = f (Just x) -withSignalMatch f Failure = f Nothing -withSignalMatch _ NoMatch = return () - -matchPropertyChanged :: IsVariant a => InterfaceName -> String -> [Variant] - -> SignalMatch a -matchPropertyChanged iface property [i, body, _] = - let i' = (fromVariant i :: Maybe String) - b = toMap body in - case (i', b) of - (Just i'', Just b') -> if i'' == formatInterfaceName iface then - maybe NoMatch Match $ fromVariant =<< M.lookup property b' - else NoMatch - _ -> Failure - where - toMap v = fromVariant v :: Maybe (M.Map String Variant) -matchPropertyChanged _ _ _ = Failure - -callPropertyGet :: BusName -> ObjectPath -> InterfaceName -> String -> Client - -> IO [Variant] -callPropertyGet bus path iface property client = either (const []) (:[]) - <$> getProperty client (methodCall path iface $ memberName_ property) - { methodCallDestination = Just bus } - diff --git a/lib/XMonad/Internal/DBus/Control.hs b/lib/XMonad/Internal/DBus/Control.hs index 78730fa..570f5c9 100644 --- a/lib/XMonad/Internal/DBus/Control.hs +++ b/lib/XMonad/Internal/DBus/Control.hs @@ -10,16 +10,14 @@ module XMonad.Internal.DBus.Control , withDBusClient , withDBusClient_ , stopXMonadService - , pathExists , disconnect ) where import Control.Monad (forM_, void) -import Data.Either - import DBus import DBus.Client +import DBus.Internal import XMonad.Internal.DBus.Brightness.ClevoKeyboard import XMonad.Internal.DBus.Brightness.IntelBacklight @@ -27,12 +25,6 @@ import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Screensaver import XMonad.Internal.Dependency -introspectInterface :: InterfaceName -introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable" - -introspectMethod :: MemberName -introspectMethod = memberName_ "Introspect" - startXMonadService :: IO (Maybe Client) startXMonadService = do client <- getDBusClient False @@ -47,7 +39,6 @@ stopXMonadService client = do void $ releaseName client xmonadBusName disconnect client - requestXMonadName :: Client -> IO () requestXMonadName client = do res <- requestName client xmonadBusName [] @@ -60,11 +51,3 @@ requestXMonadName client = do forM_ msg putStrLn where xn = "'" ++ formatBusName xmonadBusName ++ "'" - -pathExists :: Bool -> BusName -> ObjectPath -> IO Bool -pathExists sysbus n p = do - client <- if sysbus then connectSystem else connectSession - r <- call client (methodCall p introspectInterface introspectMethod) - { methodCallDestination = Just n } - disconnect client - return $ isRight r diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index 687a5b8..8598cfa 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/lib/XMonad/Internal/DBus/Screensaver.hs @@ -13,6 +13,7 @@ import Control.Monad (void) import DBus import DBus.Client +import DBus.Internal import qualified DBus.Introspection as I import Graphics.X11.XScreenSaver diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index d3c9a0d..80a24b6 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/lib/XMonad/Internal/Dependency.hs @@ -34,38 +34,24 @@ module XMonad.Internal.Dependency , executeFeature_ , executeFeatureWith , executeFeatureWith_ - , callMethod - , callMethod' - , callGetManagedObjects - , ObjectTree - , getManagedObjects - , omInterface - , addInterfaceAddedListener - , addInterfaceRemovedListener ) where import Control.Monad.IO.Class import Control.Monad.Identity -import Data.Bifunctor (bimap) -import Data.List (find) -import qualified Data.Map as M -import Data.Maybe (catMaybes, fromMaybe, listToMaybe) +import Data.List (find) +import Data.Maybe (catMaybes, fromMaybe, listToMaybe) import DBus import DBus.Client -import qualified DBus.Introspection as I +import DBus.Internal +import qualified DBus.Introspection as I -import System.Directory - ( findExecutable - , readable - , writable - ) +import System.Directory (findExecutable, readable, writable) import System.Environment import System.Exit -import XMonad.Core (X, io) -import XMonad.Internal.DBus.Common +import XMonad.Core (X, io) import XMonad.Internal.IO import XMonad.Internal.Process import XMonad.Internal.Shell @@ -332,16 +318,6 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable" introspectMethod :: MemberName introspectMethod = memberName_ "Introspect" --- TODO this belongs somewhere else, IDK where tho for now -callMethod' :: Client -> MethodCall -> IO (Either String [Variant]) -callMethod' cl = fmap (bimap methodErrorMessage methodReturnBody) . call cl - -callMethod :: Client -> BusName -> ObjectPath -> InterfaceName -> MemberName - -> IO (Either String [Variant]) -callMethod client bus path iface mem = - callMethod' client (methodCall path iface mem) - { methodCallDestination = Just bus } - dbusDepSatisfied :: Client -> DBusDep -> IO (Maybe String) dbusDepSatisfied client (Bus bus) = do ret <- callMethod client queryBus queryPath queryIface queryMem @@ -389,41 +365,3 @@ dbusDepSatisfied client (Endpoint busname objpath iface mem) = do , formatBusName busname ] --------------------------------------------------------------------------------- --- | Object Manager - -type ObjectTree = M.Map ObjectPath (M.Map String (M.Map String Variant)) - -omInterface :: InterfaceName -omInterface = interfaceName_ "org.freedesktop.DBus.ObjectManager" - -getManagedObjects :: MemberName -getManagedObjects = memberName_ "GetManagedObjects" - -callGetManagedObjects :: Client -> BusName -> ObjectPath -> IO ObjectTree -callGetManagedObjects client bus path = - either (const M.empty) (fromMaybe M.empty . (fromVariant <=< listToMaybe)) - <$> callMethod client bus path omInterface getManagedObjects - -omInterfacesAdded :: MemberName -omInterfacesAdded = memberName_ "InterfacesAdded" - -omInterfacesRemoved :: MemberName -omInterfacesRemoved = memberName_ "InterfacesRemoved" - --- TODO add busname back to this (use NameGetOwner on org.freedesktop.DBus) -addInterfaceChangedListener :: MemberName -> ObjectPath -> SignalCallback - -> Client -> IO () -addInterfaceChangedListener prop path = fmap void . addMatchCallback rule - where - rule = matchAny - { matchPath = Just path - , matchInterface = Just omInterface - , matchMember = Just prop - } - -addInterfaceAddedListener :: ObjectPath -> SignalCallback -> Client -> IO () -addInterfaceAddedListener = addInterfaceChangedListener omInterfacesAdded - -addInterfaceRemovedListener :: ObjectPath -> SignalCallback -> Client -> IO () -addInterfaceRemovedListener = addInterfaceChangedListener omInterfacesRemoved diff --git a/lib/Xmobar/Plugins/Bluetooth.hs b/lib/Xmobar/Plugins/Bluetooth.hs index ce7d95e..0ceec98 100644 --- a/lib/Xmobar/Plugins/Bluetooth.hs +++ b/lib/Xmobar/Plugins/Bluetooth.hs @@ -41,13 +41,13 @@ import Control.Monad import Data.List import Data.List.Split -import qualified Data.Map as M +import qualified Data.Map as M import Data.Maybe import DBus import DBus.Client +import DBus.Internal -import XMonad.Internal.DBus.Common import XMonad.Internal.Dependency import Xmobar import Xmobar.Plugins.Common diff --git a/lib/Xmobar/Plugins/Common.hs b/lib/Xmobar/Plugins/Common.hs index c3f90d0..24acaa5 100644 --- a/lib/Xmobar/Plugins/Common.hs +++ b/lib/Xmobar/Plugins/Common.hs @@ -14,11 +14,11 @@ import Control.Monad import DBus import DBus.Client +import DBus.Internal import Data.Maybe -import XMonad.Hooks.DynamicLog (xmobarColor) -import XMonad.Internal.DBus.Common +import XMonad.Hooks.DynamicLog (xmobarColor) type Callback = String -> IO () diff --git a/lib/Xmobar/Plugins/Device.hs b/lib/Xmobar/Plugins/Device.hs index 39cb86f..1beaf74 100644 --- a/lib/Xmobar/Plugins/Device.hs +++ b/lib/Xmobar/Plugins/Device.hs @@ -16,8 +16,8 @@ import Data.Word import DBus import DBus.Client +import DBus.Internal -import XMonad.Internal.DBus.Common import XMonad.Internal.Dependency import Xmobar import Xmobar.Plugins.Common diff --git a/lib/Xmobar/Plugins/VPN.hs b/lib/Xmobar/Plugins/VPN.hs index 56e6cd2..7b2890e 100644 --- a/lib/Xmobar/Plugins/VPN.hs +++ b/lib/Xmobar/Plugins/VPN.hs @@ -10,8 +10,8 @@ module Xmobar.Plugins.VPN ) where import DBus +import DBus.Internal -import XMonad.Internal.DBus.Common import XMonad.Internal.Dependency import Xmobar import Xmobar.Plugins.Common diff --git a/my-xmonad.cabal b/my-xmonad.cabal index 9fddca9..6ecde78 100644 --- a/my-xmonad.cabal +++ b/my-xmonad.cabal @@ -16,11 +16,11 @@ library , XMonad.Internal.Command.Desktop , XMonad.Internal.Command.DMenu , XMonad.Internal.Command.Power - , XMonad.Internal.DBus.Common , XMonad.Internal.DBus.Brightness.IntelBacklight , XMonad.Internal.DBus.Brightness.ClevoKeyboard , XMonad.Internal.DBus.Brightness.Common , XMonad.Internal.DBus.Control + , XMonad.Internal.DBus.Common , XMonad.Internal.DBus.Screensaver , XMonad.Internal.DBus.Removable , XMonad.Internal.Process @@ -32,6 +32,7 @@ library , Xmobar.Plugins.IntelBacklight , Xmobar.Plugins.Screensaver , Xmobar.Plugins.VPN + , DBus.Internal build-depends: X11 >= 1.9.1 , base , bytestring >= 0.10.8.2