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

{-# LANGUAGE OverloadedStrings #-}

--------------------------------------------------------------------------------
-- 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>".
--
-- This plugin will reflect if the adapter is powered and if any device is
-- connected to it. The rough outline for this procedure:
-- 1) get the adapter from the object manager
-- 2) get all devices associated with the adapter using the object interface
-- 3) determine if the adapter is powered
-- 4) determine if any devices are connected
-- 5) format the icon; powered vs not powered controls the color and connected
--    vs not connected controls the icon (connected bluetooth symbol has two
--    dots flanking it)
--
-- Step 3 can be accomplished using the "org.bluez.Adapter1" interface and
-- querying the "Powered" property. Step 4 can be done using the
-- "org.bluez.Device1" interface and the "Connected" property for each device
-- path. Since these are properties, we can asynchronously read changes to them
-- via the "PropertiesChanged" signal.
--
-- If any devices are added/removed, steps 2-4 will need to be redone and any
-- listeners will need to be updated. (TODO not sure which signals to use in
-- determining if a device is added)
--
-- TODO also not sure if I need to care about multiple adapters and/or the
-- adapter changing.

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.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 (Just "bluetooth.log") $ startAdapter icons colors cb

startAdapter
  :: Icons
  -> Colors
  -> Callback
  -> SysClient
  -> RIO SimpleApp ()
startAdapter is cs cb cl = do
  state <- newMVar emptyState
  let dpy = displayIcon cb (iconFormatter is cs)
  mapRIO (BTEnv cl state dpy) $ do
    ot <- getBtObjectTree
    case findAdapter ot of
      Nothing -> logError "could not find bluetooth adapter"
      Just adapter -> do
        -- set up adapter
        initAdapter adapter
        void $ addAdaptorListener adapter
        -- set up devices on the adapter (and listeners for adding/removing devices)
        let devices = findDevices adapter ot
        addDeviceAddedListener adapter
        addDeviceRemovedListener adapter
        forM_ devices $ \d -> addAndInitDevice d
        -- after setting things up, show the icon based on the initialized state
        dpy
        -- keep file descriptors open in callback threads
        forever $ threadDelay 1000000

--------------------------------------------------------------------------------
-- 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
--
-- The signal handlers all run on separate threads, yet the icon depends on
-- the state reflected by all these signals. The best (only?) way to do this is
-- is to track the shared state of the bluetooth adaptor and its devices using
-- an MVar.

data BTEnv c = BTEnv
  { btClient :: !c
  , btState :: !(MVar BtState)
  , btDisplay :: !(BTIO ())
  , btEnv :: !SimpleApp
  }

instance HasClient BTEnv where
  clientL = lens btClient (\x y -> x {btClient = y})

instance HasLogFunc (BTEnv a) where
  logFuncL = lens btEnv (\x y -> x {btEnv = y}) . logFuncL

type BTIO = RIO (BTEnv SysClient)

data BTDevice = BTDevice
  { btDevConnected :: Maybe Bool
  , btDevSigHandler :: SignalHandler
  }

type ConnectedDevices = M.Map ObjectPath BTDevice

data BtState = BtState
  { btDevices :: ConnectedDevices
  , btPowered :: Maybe Bool
  }

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

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

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

beforeDisplay :: BTIO () -> BTIO ()
beforeDisplay f = f >> join (asks btDisplay)

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

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

findDevices :: ObjectPath -> ObjectTree -> [ObjectPath]
findDevices adapter = filter (adaptorHasDevice adapter) . M.keys

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_ "/"

addBtOMListener
  :: ( HasClient env
     , SafeClient c
     , MonadReader (env c) m
     , HasLogFunc (env c)
     , MonadUnliftIO m
     )
  => SignalCallback m
  -> m ()
addBtOMListener sc = void $ addInterfaceAddedListener btBus btOMPath sc

addDeviceAddedListener :: ObjectPath -> BTIO ()
addDeviceAddedListener adapter = addBtOMListener addDevice
  where
    addDevice = pathCallback adapter $ \d ->
      addAndInitDevice d

addDeviceRemovedListener :: ObjectPath -> BTIO ()
addDeviceRemovedListener adapter =
  addBtOMListener remDevice
  where
    remDevice = pathCallback adapter $ \d -> do
      old <- removeDevice d
      cl <- asks btClient
      forM_ old $ liftIO . removeMatch (toClient cl) . btDevSigHandler

pathCallback :: ObjectPath -> (ObjectPath -> BTIO ()) -> SignalCallback BTIO
pathCallback adapter f [device, _] = forM_ (fromVariant device) $ \d -> do
  when (adaptorHasDevice adapter d) $ beforeDisplay $ f d
pathCallback _ _ _ = return ()

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

initAdapter :: ObjectPath -> BTIO ()
initAdapter adapter = do
  reply <- callGetPowered adapter
  logInfo $ "initializing adapter at path " <> adapter_
  -- TODO this could fail if the variant is something weird; the only
  -- indication I will get is "NA"
  putPowered $ fromSingletonVariant reply
  where
    adapter_ = displayWrapQuote $ displayObjectPath adapter

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

withBTPropertyRule
  :: ( SafeClient c
     , MonadReader (env c) m
     , HasLogFunc (env c)
     , HasClient env
     , MonadUnliftIO m
     , IsVariant a
     )
  => ObjectPath
  -> (Maybe a -> m ())
  -> InterfaceName
  -> T.Text
  -> m (Maybe SignalHandler)
withBTPropertyRule path update iface prop = do
  res <- matchBTProperty path
  case res of
    Just rule -> Just <$> addMatchCallback rule (signalToUpdate . matchConnected)
    Nothing -> do
      logError $
        "could not add listener for prop "
          <> prop_
          <> " on path "
          <> path_
      return Nothing
  where
    path_ = displayObjectPath path
    prop_ = Utf8Builder $ encodeUtf8Builder prop
    signalToUpdate = withSignalMatch update
    matchConnected = matchPropertyChanged iface prop

addAdaptorListener :: ObjectPath -> BTIO (Maybe SignalHandler)
addAdaptorListener adaptor =
  withBTPropertyRule adaptor procMatch adapterInterface adaptorPowered
  where
    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 adapterInterface $
    memberName_ $
      T.unpack adaptorPowered

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

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

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

adaptorPowered :: T.Text
adaptorPowered = "Powered"

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

addAndInitDevice :: ObjectPath -> BTIO ()
addAndInitDevice device = do
  res <- addDeviceListener device
  case res of
    Just handler -> do
      logInfo $ "initializing device at path " <> device_
      initDevice handler device
    Nothing -> logError $ "could not initialize device at path " <> device_
  where
    device_ = displayWrapQuote $ displayObjectPath device

initDevice :: SignalHandler -> ObjectPath -> BTIO ()
initDevice sh device = do
  reply <- callGetConnected device
  void $
    insertDevice device $
      BTDevice
        { btDevConnected = fromVariant =<< listToMaybe reply
        , btDevSigHandler = sh
        }

addDeviceListener :: ObjectPath -> BTIO (Maybe SignalHandler)
addDeviceListener device =
  withBTPropertyRule device procMatch devInterface devConnected
  where
    procMatch = beforeDisplay . void . updateDevice device

callGetConnected
  :: ( SafeClient c
     , HasClient env
     , MonadReader (env c) m
     , HasLogFunc (env c)
     , MonadUnliftIO m
     )
  => ObjectPath
  -> m [Variant]
callGetConnected p =
  callPropertyGet btBus p devInterface $
    memberName_ (T.unpack devConnected)

insertDevice :: ObjectPath -> BTDevice -> BTIO Bool
insertDevice device dev = modifyState $ \s -> do
  let new = M.insert device dev $ btDevices s
  return (s {btDevices = new}, anyDevicesConnected new)

updateDevice :: ObjectPath -> Maybe Bool -> BTIO Bool
updateDevice device status = modifyState $ \s -> do
  let new = M.update (\d -> Just d {btDevConnected = status}) device $ btDevices s
  return (s {btDevices = new}, anyDevicesConnected new)

anyDevicesConnected :: ConnectedDevices -> Bool
anyDevicesConnected = or . mapMaybe btDevConnected . M.elems

removeDevice :: ObjectPath -> BTIO (Maybe BTDevice)
removeDevice device = modifyState $ \s -> do
  let devs = btDevices s
  return (s {btDevices = M.delete device devs}, M.lookup device devs)

readDevices :: BTIO ConnectedDevices
readDevices = fmap btDevices $ readMVar =<< asks btState

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

devConnected :: T.Text
devConnected = "Connected"