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

--------------------------------------------------------------------------------
-- | 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
  ) where

import           RIO
import qualified RIO.Map     as M
import qualified RIO.Text    as T

import           DBus
import           DBus.Client

--------------------------------------------------------------------------------
-- | Type-safe client

class SafeClient c where
  toClient :: c -> Client

  getDBusClient
    :: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
    => m (Maybe c)

  disconnectDBusClient
    :: (MonadUnliftIO m)
    => c
    -> m ()
  disconnectDBusClient = liftIO . disconnect . toClient

  withDBusClient
    :: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
    => (c -> m a)
    -> m (Maybe a)
  -- TODO bracket
  withDBusClient f = do
    client <- getDBusClient
    forM client $ \c -> do
      r <- f c
      liftIO $ disconnect (toClient c)
      return r

  withDBusClient_
    :: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
    => (c -> m ())
    -> m ()
  withDBusClient_ = void . withDBusClient

  fromDBusClient
    :: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
    => (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_
  :: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
  => Bool
  -> m (Maybe Client)
getDBusClient_ sys = do
  res <- try $ liftIO $ if sys then connectSystem else connectSession
  case res of
    Left e  -> do
      logError $ Utf8Builder $ encodeUtf8Builder $ T.pack $ clientErrorMessage e
      return Nothing
    Right c -> return $ Just c

--------------------------------------------------------------------------------
-- | Methods

type MethodBody = Either T.Text [Variant]

callMethod' :: (MonadIO m, SafeClient c) => c -> MethodCall -> m MethodBody
callMethod' cl =
  liftIO
  . fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
  . call (toClient cl)

callMethod :: (MonadIO 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 :: (MonadIO m, SafeClient c) => c -> BusName -> m (Maybe BusName)
callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc
  where
    mc = (methodCallBus dbusName dbusPath dbusInterface mem)
      { methodCallBody = [toVariant name] }
    mem = memberName_ "GetNameOwner"

--------------------------------------------------------------------------------
-- | Variant parsing

fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a
fromSingletonVariant = fromVariant <=< listToMaybe

bodyToMaybe :: IsVariant a => MethodBody -> Maybe a
bodyToMaybe = either (const Nothing) fromSingletonVariant

--------------------------------------------------------------------------------
-- | Signals

type SignalCallback = [Variant] -> IO ()

addMatchCallback
  :: (MonadIO m, SafeClient c)
  => MatchRule
  -> SignalCallback
  -> c
  -> m SignalHandler
addMatchCallback rule cb cl =
  liftIO $ addMatch (toClient cl) rule $ 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
  :: (MonadIO m, SafeClient c)
  => c
  -> BusName
  -> Maybe ObjectPath
  -> Maybe InterfaceName
  -> Maybe MemberName
  -> m (Maybe MatchRule)
matchSignalFull client b p i m =
  fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b

--------------------------------------------------------------------------------
-- | Properties

propertyInterface :: InterfaceName
propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"

propertySignal :: MemberName
propertySignal = memberName_ "PropertiesChanged"

callPropertyGet :: (MonadIO m, SafeClient c) => BusName -> ObjectPath -> InterfaceName
  -> MemberName -> c -> m [Variant]
callPropertyGet bus path iface property cl =
  liftIO
  $ fmap (either (const []) (:[]))
  $ getProperty (toClient cl) $ methodCallBus bus path iface property

matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule
matchProperty b p =
  matchSignal b p (Just propertyInterface) (Just propertySignal)

matchPropertyFull
  :: (MonadIO 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 :: Monad 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
  :: (MonadIO m, SafeClient c)
  => c
  -> BusName
  -> ObjectPath
  -> m ObjectTree
callGetManagedObjects cl bus path =
  either (const M.empty) (fromMaybe M.empty . fromSingletonVariant)
  <$> callMethod cl bus path omInterface getManagedObjects

addInterfaceChangedListener
  :: (MonadIO m, SafeClient c)
  => BusName
  -> MemberName
  -> ObjectPath
  -> SignalCallback
  -> c
  -> m (Maybe SignalHandler)
addInterfaceChangedListener bus prop path sc cl = do
  rule <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop)
  forM rule $ \r -> addMatchCallback r sc cl

addInterfaceAddedListener
  :: (MonadIO m, SafeClient c)
  => BusName
  -> ObjectPath
  -> SignalCallback
  -> c
  -> m (Maybe SignalHandler)
addInterfaceAddedListener bus =
  addInterfaceChangedListener bus omInterfacesAdded

addInterfaceRemovedListener
  :: (MonadIO m, SafeClient c)
  => BusName
  -> ObjectPath
  -> SignalCallback
  -> c
  -> m (Maybe SignalHandler)
addInterfaceRemovedListener bus =
  addInterfaceChangedListener bus omInterfacesRemoved