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

--------------------------------------------------------------------------------
-- Common internal DBus functions

module Data.Internal.DBus
  ( SafeClient (..)
  , SysClient (..)
  , SesClient (..)
  , DBusEnv (..)
  , DIO
  , HasClient (..)
  , withDIO
  , 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

data DBusEnv env c = DBusEnv {dClient :: !c, dEnv :: !env}

type DIO env c = RIO (DBusEnv env c)

instance HasClient (DBusEnv SimpleApp) where
  clientL = lens dClient (\x y -> x {dClient = y})

instance HasLogFunc (DBusEnv SimpleApp c) where
  logFuncL = lens dEnv (\x y -> x {dEnv = y}) . logFuncL

withDIO
  :: (MonadUnliftIO m, MonadReader env m)
  => c
  -> DIO env c a
  -> m a
withDIO cl x = do
  env <- ask
  runRIO (DBusEnv cl env) x

class HasClient env where
  clientL :: SafeClient c => Lens' (env c) c

--------------------------------------------------------------------------------
-- Methods

type MethodBody = Either T.Text [Variant]

callMethod'
  :: (SafeClient c, MonadUnliftIO m, MonadReader (env c) m, HasClient env)
  => MethodCall
  -> m MethodBody
callMethod' mc = do
  cl <- toClient <$> view clientL
  liftIO $ bimap (T.pack . methodErrorMessage) methodReturnBody <$> call cl mc

callMethod
  :: (SafeClient c, MonadUnliftIO m, MonadReader (env c) m, HasClient env)
  => BusName
  -> ObjectPath
  -> InterfaceName
  -> MemberName
  -> m MethodBody
callMethod bus path iface = callMethod' . 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
  :: ( SafeClient c
     , MonadUnliftIO m
     , MonadReader (env c) m
     , HasClient env
     , HasLogFunc (env c)
     )
  => BusName
  -> m (Maybe BusName)
callGetNameOwner name = do
  res <- callMethod' 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
  :: ( MonadReader (env c) m
     , MonadUnliftIO m
     , SafeClient c
     , HasClient env
     )
  => MatchRule
  -> SignalCallback m
  -> m SignalHandler
addMatchCallback rule cb = do
  cl <- toClient <$> view clientL
  withRunInIO $ \run -> do
    addMatch 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 c) m
     , HasLogFunc (env c)
     , MonadUnliftIO m
     , SafeClient c
     , HasClient env
     )
  => BusName
  -> Maybe ObjectPath
  -> Maybe InterfaceName
  -> Maybe MemberName
  -> m (Maybe MatchRule)
matchSignalFull b p i m = do
  res <- callGetNameOwner 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
  :: ( HasClient env
     , MonadReader (env c) m
     , HasLogFunc (env c)
     , MonadUnliftIO m
     , SafeClient c
     )
  => BusName
  -> ObjectPath
  -> InterfaceName
  -> MemberName
  -> m [Variant]
callPropertyGet bus path iface property = do
  cl <- toClient <$> view clientL
  res <- liftIO $ getProperty 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 c) m
     , HasLogFunc (env c)
     , MonadUnliftIO m
     , SafeClient c
     , HasClient env
     )
  => BusName
  -> Maybe ObjectPath
  -> m (Maybe MatchRule)
matchPropertyFull b p =
  matchSignalFull 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 c) m
     , HasLogFunc (env c)
     , MonadUnliftIO m
     , SafeClient c
     , HasClient env
     )
  => BusName
  -> ObjectPath
  -> m ObjectTree
callGetManagedObjects bus path = do
  res <- callMethod 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 c) m
     , HasLogFunc (env c)
     , MonadUnliftIO m
     , SafeClient c
     , HasClient env
     )
  => BusName
  -> MemberName
  -> ObjectPath
  -> SignalCallback m
  -> m (Maybe SignalHandler)
addInterfaceChangedListener bus prop path sc = do
  res <- matchSignalFull 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
  where
    bus_ = "'" <> displayBusName bus <> "'"
    path_ = "'" <> displayObjectPath path <> "'"
    prop_ = "'" <> displayMemberName prop <> "'"

addInterfaceAddedListener
  :: ( MonadReader (env c) m
     , HasLogFunc (env c)
     , MonadUnliftIO m
     , SafeClient c
     , HasClient env
     )
  => BusName
  -> ObjectPath
  -> SignalCallback m
  -> m (Maybe SignalHandler)
addInterfaceAddedListener bus =
  addInterfaceChangedListener bus omInterfacesAdded

addInterfaceRemovedListener
  :: ( MonadReader (env c) m
     , HasLogFunc (env c)
     , MonadUnliftIO m
     , SafeClient c
     , HasClient env
     )
  => BusName
  -> ObjectPath
  -> SignalCallback m
  -> 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 <> "'"