xmonad-config/lib/Data/Internal/DBus.hs

401 lines
11 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- Common internal DBus functions
module Data.Internal.DBus
( SafeClient (..)
, SysClient (..)
, SesClient (..)
, addMatchCallback
, matchProperty
, matchPropertyFull
, matchPropertyChanged
, SignalMatch (..)
, SignalCallback
, MethodBody
, withSignalMatch
, callPropertyGet
, callMethod
, callMethod'
, methodCallBus
, callGetManagedObjects
, ObjectTree
, getManagedObjects
, omInterface
, addInterfaceAddedListener
, addInterfaceRemovedListener
, fromSingletonVariant
, bodyToMaybe
, exportPair
, displayBusName
, displayObjectPath
, displayMemberName
, displayInterfaceName
, displayWrapQuote
)
where
import DBus
import DBus.Client
import qualified Data.ByteString.Char8 as BC
import RIO
import RIO.List
import qualified RIO.Map as M
import qualified RIO.Text as T
--------------------------------------------------------------------------------
-- Type-safe client
class SafeClient c where
toClient :: c -> Client
getDBusClient
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> m (Maybe c)
disconnectDBusClient :: MonadUnliftIO m => c -> m ()
disconnectDBusClient = liftIO . disconnect . toClient
withDBusClient
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (c -> m a)
-> m (Maybe a)
withDBusClient f =
bracket getDBusClient (mapM (liftIO . disconnect . toClient)) $ mapM f
withDBusClient_
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (c -> m ())
-> m ()
withDBusClient_ = void . withDBusClient
fromDBusClient
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (c -> a)
-> m (Maybe a)
fromDBusClient f = withDBusClient (return . f)
newtype SysClient = SysClient Client
instance SafeClient SysClient where
toClient (SysClient cl) = cl
getDBusClient = fmap SysClient <$> getDBusClient' True
newtype SesClient = SesClient Client
instance SafeClient SesClient where
toClient (SesClient cl) = cl
getDBusClient = fmap SesClient <$> getDBusClient' False
getDBusClient'
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Bool
-> m (Maybe Client)
getDBusClient' sys = do
res <- try $ liftIO $ if sys then connectSystem else connectSession
case res of
Left e -> do
logInfo $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
return Nothing
Right c -> return $ Just c
--------------------------------------------------------------------------------
-- Methods
type MethodBody = Either T.Text [Variant]
callMethod' :: (MonadUnliftIO m, SafeClient c) => c -> MethodCall -> m MethodBody
callMethod' cl =
liftIO
. fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
. call (toClient cl)
callMethod
:: (MonadUnliftIO m, SafeClient c)
=> c
-> BusName
-> ObjectPath
-> InterfaceName
-> MemberName
-> m MethodBody
callMethod client bus path iface = callMethod' client . methodCallBus bus path iface
methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall
methodCallBus b p i m =
(methodCall p i m)
{ methodCallDestination = Just b
}
--------------------------------------------------------------------------------
-- Bus names
dbusInterface :: InterfaceName
dbusInterface = interfaceName_ "org.freedesktop.DBus"
callGetNameOwner
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
=> c
-> BusName
-> m (Maybe BusName)
callGetNameOwner cl name = do
res <- callMethod' cl mc
case res of
Left err -> do
logError $ Utf8Builder $ encodeUtf8Builder err
return Nothing
Right body -> return $ fromSingletonVariant body
where
mc =
(methodCallBus dbusName dbusPath dbusInterface mem)
{ methodCallBody = [toVariant name]
}
mem = memberName_ "GetNameOwner"
--------------------------------------------------------------------------------
-- Variant parsing
-- TODO log failures here?
fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a
fromSingletonVariant = fromVariant <=< listToMaybe
bodyToMaybe :: IsVariant a => MethodBody -> Maybe a
bodyToMaybe = either (const Nothing) fromSingletonVariant
--------------------------------------------------------------------------------
-- Signals
type SignalCallback m = [Variant] -> m ()
addMatchCallback
:: (MonadUnliftIO m, SafeClient c)
=> MatchRule
-> SignalCallback m
-> c
-> m SignalHandler
addMatchCallback rule cb cl = withRunInIO $ \run -> do
addMatch (toClient cl) rule $ run . cb . signalBody
matchSignal
:: Maybe BusName
-> Maybe ObjectPath
-> Maybe InterfaceName
-> Maybe MemberName
-> MatchRule
matchSignal b p i m =
matchAny
{ matchPath = p
, matchSender = b
, matchInterface = i
, matchMember = m
}
matchSignalFull
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
=> c
-> BusName
-> Maybe ObjectPath
-> Maybe InterfaceName
-> Maybe MemberName
-> m (Maybe MatchRule)
matchSignalFull client b p i m = do
res <- callGetNameOwner client b
case res of
Just o -> return $ Just $ matchSignal (Just o) p i m
Nothing -> do
logError msg
return Nothing
where
bus_ = displayWrapQuote $ displayBusName b
iface_ = displayWrapQuote . displayInterfaceName <$> i
path_ = displayWrapQuote . displayObjectPath <$> p
mem_ = displayWrapQuote . displayMemberName <$> m
match =
intersperse ", " $
mapMaybe (\(k, v) -> fmap ((k <> "=") <>) v) $
zip ["interface", "path", "member"] [iface_, path_, mem_]
stem = "could not get match rule for bus " <> bus_
msg = if null match then stem else stem <> " where " <> mconcat match
--------------------------------------------------------------------------------
-- Properties
propertyInterface :: InterfaceName
propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
propertySignal :: MemberName
propertySignal = memberName_ "PropertiesChanged"
callPropertyGet
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
=> BusName
-> ObjectPath
-> InterfaceName
-> MemberName
-> c
-> m [Variant]
callPropertyGet bus path iface property cl = do
res <- liftIO $ getProperty (toClient cl) $ methodCallBus bus path iface property
case res of
Left err -> do
logError $ displayBytesUtf8 $ BC.pack $ methodErrorMessage err
return []
Right v -> return [v]
matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule
matchProperty b p =
matchSignal b p (Just propertyInterface) (Just propertySignal)
matchPropertyFull
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
=> c
-> BusName
-> Maybe ObjectPath
-> m (Maybe MatchRule)
matchPropertyFull cl b p =
matchSignalFull cl b p (Just propertyInterface) (Just propertySignal)
data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show)
withSignalMatch :: MonadUnliftIO m => (Maybe a -> m ()) -> SignalMatch a -> m ()
withSignalMatch f (Match x) = f (Just x)
withSignalMatch f Failure = f Nothing
withSignalMatch _ NoMatch = return ()
matchPropertyChanged
:: IsVariant a
=> InterfaceName
-> T.Text
-> [Variant]
-> SignalMatch a
matchPropertyChanged iface property [i, body, _] =
let i' = (fromVariant i :: Maybe T.Text)
b = toMap body
in case (i', b) of
(Just i'', Just b') ->
if i'' == T.pack (formatInterfaceName iface)
then maybe NoMatch Match $ fromVariant =<< M.lookup property b'
else NoMatch
_ -> Failure
where
toMap v = fromVariant v :: Maybe (M.Map T.Text Variant)
matchPropertyChanged _ _ _ = Failure
--------------------------------------------------------------------------------
-- Object Manager
type ObjectTree = M.Map ObjectPath (M.Map T.Text (M.Map T.Text Variant))
omInterface :: InterfaceName
omInterface = interfaceName_ "org.freedesktop.DBus.ObjectManager"
getManagedObjects :: MemberName
getManagedObjects = memberName_ "GetManagedObjects"
omInterfacesAdded :: MemberName
omInterfacesAdded = memberName_ "InterfacesAdded"
omInterfacesRemoved :: MemberName
omInterfacesRemoved = memberName_ "InterfacesRemoved"
callGetManagedObjects
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
=> c
-> BusName
-> ObjectPath
-> m ObjectTree
callGetManagedObjects cl bus path = do
res <- callMethod cl bus path omInterface getManagedObjects
case res of
Left err -> do
logError $ Utf8Builder $ encodeUtf8Builder err
return M.empty
Right v -> return $ fromMaybe M.empty $ fromSingletonVariant v
addInterfaceChangedListener
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
=> BusName
-> MemberName
-> ObjectPath
-> SignalCallback m
-> c
-> m (Maybe SignalHandler)
addInterfaceChangedListener bus prop path sc cl = do
res <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop)
case res of
Nothing -> do
logError $
"could not add listener for property"
<> prop_
<> " at path "
<> path_
<> " on bus "
<> bus_
return Nothing
Just rule -> Just <$> addMatchCallback rule sc cl
where
bus_ = "'" <> displayBusName bus <> "'"
path_ = "'" <> displayObjectPath path <> "'"
prop_ = "'" <> displayMemberName prop <> "'"
addInterfaceAddedListener
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
=> BusName
-> ObjectPath
-> SignalCallback m
-> c
-> m (Maybe SignalHandler)
addInterfaceAddedListener bus =
addInterfaceChangedListener bus omInterfacesAdded
addInterfaceRemovedListener
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
=> BusName
-> ObjectPath
-> SignalCallback m
-> c
-> m (Maybe SignalHandler)
addInterfaceRemovedListener bus =
addInterfaceChangedListener bus omInterfacesRemoved
--------------------------------------------------------------------------------
-- Interface export/unexport
exportPair
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
=> ObjectPath
-> (Client -> m Interface)
-> c
-> (m (), m ())
exportPair path toIface cl = (up, down)
where
cl_ = toClient cl
up = do
logInfo $ "adding interface: " <> path_
i <- toIface cl_
liftIO $ export cl_ path i
down = do
logInfo $ "removing interface: " <> path_
liftIO $ unexport cl_ path
path_ = displayObjectPath path
--------------------------------------------------------------------------------
-- logging helpers
displayBusName :: BusName -> Utf8Builder
displayBusName = displayBytesUtf8 . BC.pack . formatBusName
displayObjectPath :: ObjectPath -> Utf8Builder
displayObjectPath = displayBytesUtf8 . BC.pack . formatObjectPath
displayMemberName :: MemberName -> Utf8Builder
displayMemberName = displayBytesUtf8 . BC.pack . formatMemberName
displayInterfaceName :: InterfaceName -> Utf8Builder
displayInterfaceName = displayBytesUtf8 . BC.pack . formatInterfaceName
displayWrapQuote :: Utf8Builder -> Utf8Builder
displayWrapQuote x = "'" <> x <> "'"