xmonad-config/lib/Xmobar/Plugins/Bluetooth.hs

--------------------------------------------------------------------------------
-- Bluetooth plugin
--
-- Use the bluez interface on DBus to check status
--
-- org.bluez dynamically updates its DBus interfaces using the standard Object
-- Manager. The adapter is located at path "/org/bluez/hci<X>" where X is
-- usually 0, and each device is "/org/bluez/hci<X>/<MAC_ADDRESS>".
--
-- Simple and somewhat crude way to do this is to have two monitors, one
-- watching the powered state of the adaptor and one listening for connection
-- changes. The former is easy since this is just one /org/bluez/hciX. For the
-- latter, each 'Connected' property is embedded in each individual device path
-- on `org.bluez.Device1', so just watch the entire bluez bus for property
-- changes and filter those that correspond to the aforementioned
-- interface/property. Track all this in a state which keeps the powered
-- property and a running list of connected devices.
--
-- TODO also not sure if I need to care about multiple adapters and/or the
-- adapter changing. For now it should just get the first adaptor and only pay
-- attention to devices associated with it.

module Xmobar.Plugins.Bluetooth
  ( Bluetooth (..)
  , btAlias
  , btDep
  )
where

import DBus
import DBus.Client
import Data.Internal.DBus
import Data.Internal.XIO
import RIO
import RIO.FilePath
import RIO.List
import qualified RIO.Map as M
import qualified RIO.Set as S
import qualified RIO.Text as T
import XMonad.Internal.DBus.Common
import Xmobar
import Xmobar.Plugins.Common

btAlias :: T.Text
btAlias = "bluetooth"

btDep :: DBusDependency_ SysClient
btDep =
  Endpoint [Package Official "bluez"] btBus btOMPath omInterface $
    Method_ getManagedObjects

data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)

instance Exec Bluetooth where
  alias (Bluetooth _ _) = T.unpack btAlias
  start (Bluetooth icons colors) cb =
    withDBusClientConnection cb Nothing (Just "bluetooth.log") $
      startAdapter icons colors cb

startAdapter
  :: Icons
  -> Colors
  -> Callback
  -> NamedSysConnection
  -> RIO SimpleApp ()
startAdapter is cs cb cl = do
  state <- newMVar emptyState
  let dpy cb' = displayIcon cb' (iconFormatter is cs)
  mapRIO (PluginEnv cl state dpy cb) $ do
    ot <- getBtObjectTree
    case findAdaptor ot of
      Nothing -> logError "could not find bluetooth adapter"
      Just adaptor -> do
        initAdapterState adaptor
        initDevicesState adaptor ot
        startAdaptorListener adaptor
        startConnectedListener adaptor
        pluginDisplay

--------------------------------------------------------------------------------
-- Icon Display
--
-- Color corresponds to the adaptor powered state, and the icon corresponds to
-- if it is paired or not. If the adaptor state is undefined, display "N/A"

type IconFormatter = (Maybe Bool -> Bool -> T.Text)

type Icons = (T.Text, T.Text)

displayIcon :: Callback -> IconFormatter -> BTIO ()
displayIcon callback formatter =
  liftIO . callback . T.unpack . uncurry formatter =<< readState

-- TODO maybe I want this to fail when any of the device statuses are Nothing
iconFormatter :: Icons -> Colors -> IconFormatter
iconFormatter (iconConn, iconDisc) cs powered connected =
  maybe na (\p -> colorText cs p icon) powered
  where
    icon = if connected then iconConn else iconDisc

--------------------------------------------------------------------------------
-- Connection State

type BTIO = PluginIO BtState SysClient

data BtState = BtState
  { btDevices :: S.Set ObjectPath
  , btPowered :: Maybe Bool
  }

emptyState :: BtState
emptyState =
  BtState
    { btDevices = S.empty
    , btPowered = Nothing
    }

readState :: BTIO (Maybe Bool, Bool)
readState = do
  p <- readPowered
  c <- readDevices
  return (p, not $ null c)

modifyState :: (BtState -> BTIO (BtState, a)) -> BTIO a
modifyState f = do
  m <- asks plugState
  modifyMVar m f

beforeDisplay :: BTIO () -> BTIO ()
beforeDisplay f = f >> pluginDisplay

--------------------------------------------------------------------------------
-- Object manager

findAdaptor :: ObjectTree -> Maybe ObjectPath
findAdaptor = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys

-- | Search the object tree for devices which are in a connected state.
-- Return the object path for said devices.
findConnectedDevices :: ObjectPath -> ObjectTree -> [ObjectPath]
findConnectedDevices adaptor =
  filter (adaptorHasDevice adaptor) . M.keys . M.filter isConnectedDev
  where
    isConnectedDev m = Just True == lookupState m
    lookupState =
      fromVariant
        <=< M.lookup (memberNameT devConnected)
        <=< M.lookup devInterface

adaptorHasDevice :: ObjectPath -> ObjectPath -> Bool
adaptorHasDevice adaptor device = case splitPathNoRoot device of
  [org, bluez, hciX, _] -> splitPathNoRoot adaptor == [org, bluez, hciX]
  _ -> False

splitPathNoRoot :: ObjectPath -> [FilePath]
splitPathNoRoot = dropWhile (== "/") . splitDirectories . formatObjectPath

getBtObjectTree
  :: ( HasClient env
     , SafeClient c
     , MonadReader (env c) m
     , HasLogFunc (env c)
     , MonadUnliftIO m
     )
  => m ObjectTree
getBtObjectTree = callGetManagedObjects btBus btOMPath

btOMPath :: ObjectPath
btOMPath = objectPath_ "/"

--------------------------------------------------------------------------------
-- Adapter

-- | Get powered state of adaptor and log the result
initAdapterState :: ObjectPath -> BTIO ()
initAdapterState adapter = do
  reply <- callGetPowered adapter
  putPowered $ fromSingletonVariant reply

matchBTProperty
  :: ( SafeClient c
     , HasClient env
     , MonadReader (env c) m
     , HasLogFunc (env c)
     , MonadUnliftIO m
     )
  => ObjectPath
  -> m (Maybe MatchRule)
matchBTProperty p = matchPropertyFull btBus (Just p)

-- | Start a listener that monitors changes to the powered state of an adaptor
startAdaptorListener :: ObjectPath -> BTIO ()
startAdaptorListener adaptor = do
  res <- matchBTProperty adaptor
  case res of
    Just rule -> void $ addMatchCallback rule callback
    Nothing -> do
      logError $
        "could not add listener for prop "
          <> displayMemberName adaptorPowered
          <> " on path "
          <> displayObjectPath adaptor
  where
    callback sig =
      withNestedDBusClientConnection Nothing Nothing $
        withSignalMatch procMatch $
          matchPropertyChanged adaptorInterface adaptorPowered sig
    procMatch = beforeDisplay . putPowered

callGetPowered
  :: ( HasClient env
     , MonadReader (env c) m
     , HasLogFunc (env c)
     , SafeClient c
     , MonadUnliftIO m
     )
  => ObjectPath
  -> m [Variant]
callGetPowered adapter =
  callPropertyGet btBus adapter adaptorInterface adaptorPowered

putPowered :: Maybe Bool -> BTIO ()
putPowered ds = modifyState $ \s -> return (s {btPowered = ds}, ())

readPowered :: BTIO (Maybe Bool)
readPowered = fmap btPowered $ readMVar =<< asks plugState

adaptorInterface :: InterfaceName
adaptorInterface = interfaceName_ "org.bluez.Adapter1"

adaptorPowered :: MemberName
adaptorPowered = "Powered"

--------------------------------------------------------------------------------
-- Devices

initDevicesState :: ObjectPath -> ObjectTree -> BTIO ()
initDevicesState adaptor ot = do
  let devices = findConnectedDevices adaptor ot
  modifyState $ \s -> return (s {btDevices = S.fromList devices}, ())

startConnectedListener :: ObjectPath -> BTIO ()
startConnectedListener adaptor = do
  reply <- matchPropertyFull btBus Nothing
  case reply of
    Just rule -> do
      void $ addMatchCallbackSignal rule callback
      logInfo $ "Started listening for device connections on " <> adaptor_
    Nothing -> logError "Could not listen for connection changes"
  where
    adaptor_ = displayWrapQuote $ displayObjectPath adaptor
    callback sig =
      withNestedDBusClientConnection Nothing Nothing $ do
        let devpath = signalPath sig
        when (adaptorHasDevice adaptor devpath) $
          withSignalMatch (update devpath) $
            matchConnected $
              signalBody sig
    matchConnected = matchPropertyChanged devInterface devConnected
    update _ Nothing = return ()
    update devpath (Just x) = do
      let f = if x then S.insert else S.delete
      beforeDisplay $
        modifyState $
          \s -> return (s {btDevices = f devpath $ btDevices s}, ())

readDevices :: BTIO (S.Set ObjectPath)
readDevices = fmap btDevices $ readMVar =<< asks plugState

devInterface :: InterfaceName
devInterface = interfaceName_ "org.bluez.Device1"

devConnected :: MemberName
devConnected = "Connected"