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

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

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

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

import DBus
import DBus.Client
import Data.Internal.DBus
import Data.Internal.Dependency
import RIO
import qualified RIO.Text as T
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 SesClient
  , dbSysClient :: Maybe SysClient
  }

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 (Maybe a)
withDBusX f = withDBus $ \db -> do
  forM (dbSesClient db) $ \ses -> do
    bracket_ (requestXMonadName ses) (releaseXMonadName ses) $ f db

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

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

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

-- | Disconnect from the DBus
disconnectDBus :: MonadUnliftIO m => DBusState -> m ()
disconnectDBus db = disc dbSesClient >> disc dbSysClient
  where
    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
  forM_ (dbSesClient db) requestXMonadName
  return db

-- | Disconnect from DBus and release the XMonad name
disconnectDBusX :: MonadUnliftIO m => DBusState -> m ()
disconnectDBusX db = do
  forM_ (dbSesClient db) releaseXMonadName
  disconnectDBus db

-- | All exporter features to be assigned to the DBus
dbusExporters :: [Maybe SesClient -> SometimesIO]
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]

releaseXMonadName :: MonadUnliftIO m => SesClient -> m ()
releaseXMonadName ses = liftIO $ void $ releaseName (toClient ses) xmonadBusName

requestXMonadName
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
  => SesClient
  -> m ()
requestXMonadName ses = do
  res <- liftIO $ requestName (toClient ses) 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 <> ": " <> xn
  where
    xn =
      Utf8Builder $
        encodeUtf8Builder $
          T.pack $
            formatBusName xmonadBusName