xmonad-config/lib/XMonad/Internal/DBus/Control.hs

--------------------------------------------------------------------------------
-- High-level interface for managing XMonad's DBus

module XMonad.Internal.DBus.Control
  ( Client
  , DBusState (..)
  , withDBusInterfaces
  , withDBusX
  , withDBusX_
  , withDBus
  , withDBus_
  , connectDBus
  , disconnectDBus
  -- , disconnectDBusX
  , getDBusClient
  , withDBusClient
  , withDBusClient_
  , disconnect
  , dbusExporters
  )
where

import DBus
import DBus.Client
import Data.Internal.DBus
import Data.Internal.XIO
import RIO
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Common
import XMonad.Internal.DBus.Screensaver

-- | Current connections to the DBus (session and system buses)
data DBusState = DBusState
  { dbSesClient :: Maybe NamedSesConnection
  , dbSysClient :: Maybe NamedSysConnection
  }

withDBusX_
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
  => (DBusState -> m a)
  -> m ()
withDBusX_ = void . withDBusX

withDBusX
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
  => (DBusState -> m a)
  -> m a
withDBusX = withDBus (Just xmonadSesBusName) Nothing

withDBus_
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
  => Maybe BusName
  -> Maybe BusName
  -> (DBusState -> m a)
  -> m ()
withDBus_ sesname sysname = void . withDBus sesname sysname

withDBus
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
  => Maybe BusName
  -> Maybe BusName
  -> (DBusState -> m a)
  -> m a
withDBus sesname sysname = bracket (connectDBus sesname sysname) disconnectDBus

-- | Connect to the DBus
connectDBus
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
  => Maybe BusName
  -> Maybe BusName
  -> m DBusState
connectDBus sesname sysname = do
  ses <- getDBusClient sesname
  sys <- getDBusClient sysname
  return DBusState {dbSesClient = ses, dbSysClient = sys}

-- | Disconnect from the DBus
disconnectDBus
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
  => DBusState
  -> m ()
disconnectDBus db = disc dbSesClient >> disc dbSysClient
  where
    disc
      :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
      => (DBusState -> Maybe (NamedConnection c))
      -> m ()
    disc f = maybe (return ()) disconnectDBusClient $ f db

-- -- | Connect to the DBus and request the XMonad name
-- connectDBusX
--   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
--   => m DBusState
-- connectDBusX = do
--   db <- connectDBus
--   requestXMonadName2 db
--   return db

-- -- | Disconnect from DBus and release the XMonad name
-- disconnectDBusX
--   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
--   => DBusState
--   -> m ()
-- disconnectDBusX db = do
--   forM_ (dbSesClient db) releaseBusName
--   forM_ (dbSysClient db) releaseBusName
--   disconnectDBus db

-- requestXMonadName2
--   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
--   => DBusState
--   -> m ()
-- requestXMonadName2 db = do
--   forM_ (dbSesClient db) requestXMonadName
--   forM_ (dbSysClient db) requestXMonadName

withDBusInterfaces
  :: DBusState
  -> [Maybe NamedSesConnection -> Sometimes (XIO (), XIO ())]
  -> ([XIO ()] -> XIO a)
  -> XIO a
withDBusInterfaces db interfaces = bracket up sequence
  where
    up = do
      pairs <- catMaybes <$> mapM (\f -> evalSometimes $ f $ dbSesClient db) interfaces
      mapM_ fst pairs
      return $ snd <$> pairs

-- | All exporter features to be assigned to the DBus
dbusExporters
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
  => [Maybe NamedSesConnection -> Sometimes (m (), m ())]
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]

-- releaseXMonadName
--   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
--   => c
--   -> m ()
-- releaseXMonadName cl = do
--   -- TODO this might error?
--   liftIO $ void $ releaseName (toClient cl) xmonadBusName
--   logInfo "released xmonad name"

-- releaseBusName
--   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
--   => BusName
--   -> c
--   -> m ()
-- releaseBusName n cl = do
--   -- TODO this might error?
--   liftIO $ void $ releaseName (toClient cl) n
--   logInfo $ "released bus name: " <> displayBusName n

-- requestBusName
--   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
--   => BusName
--   -> c
--   -> m ()
-- requestBusName n cl = do
--   res <- try $ liftIO $ requestName (toClient cl) n []
--   case res of
--     Left e -> logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
--     Right r -> do
--       let msg
--             | r == NamePrimaryOwner = "registering name"
--             | r == NameAlreadyOwner = "this process already owns name"
--             | r == NameInQueue
--                 || r == NameExists =
--                 "another process owns name"
--             -- this should never happen
--             | otherwise = "unknown error when requesting name"
--       logInfo $ msg <> ": " <> displayBusName n

-- requestXMonadName
--   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
--   => c
--   -> m ()
-- requestXMonadName cl = do
--   res <- liftIO $ requestName (toClient cl) xmonadBusName []
--   let msg
--         | res == NamePrimaryOwner = "registering name"
--         | res == NameAlreadyOwner = "this process already owns name"
--         | res == NameInQueue
--             || res == NameExists =
--             "another process owns name"
--         | otherwise = "unknown error when requesting name"
--   logInfo $ msg <> ": " <> displayBusName xmonadBusName