ndwarshuis
/
xmonad-config
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

REF move all 'common' DBus code to seperate shared module

This commit is contained in:
Nathan Dwarshuis 2021-11-27 01:02:22 -05:00
parent 7010d4a723
commit fd37220005
12 changed files with 190 additions and 186 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
bin/xmobar.hs
View File

@ -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

170
lib/DBus/Internal.hs Normal file
View File

@ -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

1
lib/XMonad/Internal/DBus/Brightness/Common.hs
View File

@ -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

94
lib/XMonad/Internal/DBus/Common.hs
View File

@ -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 }

19
lib/XMonad/Internal/DBus/Control.hs
View File

@ -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

1
lib/XMonad/Internal/DBus/Screensaver.hs
View File

@ -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

74
lib/XMonad/Internal/Dependency.hs
View File

@ -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

4
lib/Xmobar/Plugins/Bluetooth.hs
View File

@ -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

4
lib/Xmobar/Plugins/Common.hs
View File

@ -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 ()

2
lib/Xmobar/Plugins/Device.hs
View File

@ -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

2
lib/Xmobar/Plugins/VPN.hs
View File

@ -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

3
my-xmonad.cabal
View File

@ -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