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

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

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

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

import           Data.Internal.DBus
import           Data.Internal.Dependency

import           DBus
import           DBus.Client

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
    }

-- | Connect to the DBus
connectDBus
  :: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
  => 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
  :: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
  => 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 = void $ liftIO $ releaseName (toClient ses) xmonadBusName

requestXMonadName
  :: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
  => SesClient
  -> m ()
requestXMonadName ses = do
  res <- liftIO $ requestName (toClient ses) xmonadBusName []
  -- TODO if the client is not released on shutdown the owner will be different
  let msg | res == NamePrimaryOwner = Nothing
          | res == NameAlreadyOwner = Just "this process already owns bus name"
          | res == NameInQueue
            || res == NameExists = Just "another process owns bus name"
          | otherwise = Just "unknown error when requesting bus name"
  forM_ msg $ \m ->
    logError $ Utf8Builder $ encodeUtf8Builder $ T.concat [m, ": ", xn]
  where
    xn = T.pack $ formatBusName xmonadBusName