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

388 lines
12 KiB
Haskell
Raw Normal View History

{-# LANGUAGE OverloadedStrings #-}
2020-04-01 22:06:00 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Bluetooth plugin
2020-04-01 22:06:00 -04:00
--
-- 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.
2020-04-01 22:06:00 -04:00
module Xmobar.Plugins.Bluetooth
2022-12-30 14:58:23 -05:00
( Bluetooth (..)
, btAlias
2021-11-23 18:28:38 -05:00
, btDep
2022-12-30 14:58:23 -05:00
)
where
import DBus
import DBus.Client
import Data.Internal.DBus
2023-01-01 18:33:02 -05:00
import Data.Internal.XIO
2022-12-30 16:37:52 -05:00
import RIO
2022-12-31 19:47:02 -05:00
import RIO.FilePath
import RIO.List
import qualified RIO.Map as M
2022-12-30 14:58:23 -05:00
import qualified RIO.Text as T
import XMonad.Internal.DBus.Common
import Xmobar
import Xmobar.Plugins.Common
2020-03-21 01:18:38 -04:00
btAlias :: T.Text
btAlias = "bluetooth"
2022-07-09 17:08:10 -04:00
btDep :: DBusDependency_ SysClient
2022-12-30 14:58:23 -05:00
btDep =
Endpoint [Package Official "bluez"] btBus btOMPath omInterface $
Method_ getManagedObjects
data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
2020-03-21 01:18:38 -04:00
instance Exec Bluetooth where
alias (Bluetooth _ _) = T.unpack btAlias
start (Bluetooth icons colors) cb =
2023-01-03 23:33:08 -05:00
withDBusClientConnection cb (Just "bluetooth.log") $ startAdapter icons colors cb
2022-12-30 16:58:30 -05:00
startAdapter
2023-01-01 23:03:31 -05:00
:: Icons
2022-12-30 16:58:30 -05:00
-> Colors
-> Callback
-> SysClient
2023-01-01 23:03:31 -05:00
-> RIO SimpleApp ()
startAdapter is cs cb cl = do
state <- newMVar emptyState
2023-01-01 23:03:31 -05:00
let dpy = displayIcon cb (iconFormatter is cs)
2023-01-03 22:18:55 -05:00
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
2023-01-03 22:18:55 -05:00
initAdapter adapter
void $ addAdaptorListener adapter
-- set up devices on the adapter (and listeners for adding/removing devices)
let devices = findDevices adapter ot
2023-01-03 22:18:55 -05:00
addDeviceAddedListener adapter
addDeviceRemovedListener adapter
forM_ devices $ \d -> addAndInitDevice d
-- after setting things up, show the icon based on the initialized state
dpy
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- 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"
2021-11-08 00:27:39 -05:00
type IconFormatter = (Maybe Bool -> Bool -> T.Text)
type Icons = (T.Text, T.Text)
2023-01-01 23:03:31 -05:00
displayIcon :: Callback -> IconFormatter -> BTIO ()
displayIcon callback formatter =
2023-01-01 23:03:31 -05:00
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
2021-11-27 17:33:02 -05:00
iconFormatter (iconConn, iconDisc) cs powered connected =
maybe na (\p -> colorText cs p icon) powered
where
icon = if connected then iconConn else iconDisc
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- 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.
2023-01-03 22:18:55 -05:00
data BTEnv c = BTEnv
{ btClient :: !c
, btState :: !(MVar BtState)
, btDisplay :: !(BTIO ())
, btEnv :: !SimpleApp
2023-01-01 23:03:31 -05:00
}
2023-01-03 22:18:55 -05:00
instance HasClient BTEnv where
clientL = lens btClient (\x y -> x {btClient = y})
instance HasLogFunc (BTEnv a) where
2023-01-01 23:03:31 -05:00
logFuncL = lens btEnv (\x y -> x {btEnv = y}) . logFuncL
2023-01-03 22:18:55 -05:00
type BTIO = RIO (BTEnv SysClient)
2023-01-01 23:03:31 -05:00
data BTDevice = BTDevice
2022-12-30 14:58:23 -05:00
{ btDevConnected :: Maybe Bool
, btDevSigHandler :: SignalHandler
}
type ConnectedDevices = M.Map ObjectPath BTDevice
data BtState = BtState
{ btDevices :: ConnectedDevices
, btPowered :: Maybe Bool
}
emptyState :: BtState
2022-12-30 14:58:23 -05:00
emptyState =
BtState
{ btDevices = M.empty
, btPowered = Nothing
}
2023-01-01 23:03:31 -05:00
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
2023-01-02 10:33:04 -05:00
beforeDisplay :: BTIO () -> BTIO ()
beforeDisplay f = f >> join (asks btDisplay)
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- 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
2022-12-31 19:47:02 -05:00
adaptorHasDevice adaptor device = case splitPathNoRoot device of
[org, bluez, hciX, _] -> splitPathNoRoot adaptor == [org, bluez, hciX]
2022-12-30 14:58:23 -05:00
_ -> False
2022-12-31 19:47:02 -05:00
splitPathNoRoot :: ObjectPath -> [FilePath]
splitPathNoRoot = dropWhile (== "/") . splitDirectories . formatObjectPath
getBtObjectTree
2023-01-03 22:18:55 -05:00
:: ( HasClient env
, SafeClient c
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
=> m ObjectTree
getBtObjectTree = callGetManagedObjects btBus btOMPath
2021-11-08 00:27:39 -05:00
2021-11-27 13:24:13 -05:00
btOMPath :: ObjectPath
btOMPath = objectPath_ "/"
2023-01-01 19:41:46 -05:00
addBtOMListener
2023-01-03 22:18:55 -05:00
:: ( HasClient env
, SafeClient c
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
2023-01-01 19:41:46 -05:00
=> SignalCallback m
-> m ()
2023-01-03 22:18:55 -05:00
addBtOMListener sc = void $ addInterfaceAddedListener btBus btOMPath sc
2023-01-03 22:18:55 -05:00
addDeviceAddedListener :: ObjectPath -> BTIO ()
addDeviceAddedListener adapter = addBtOMListener addDevice
where
addDevice = pathCallback adapter $ \d ->
2023-01-03 22:18:55 -05:00
addAndInitDevice d
2020-03-21 14:30:27 -04:00
2023-01-03 22:18:55 -05:00
addDeviceRemovedListener :: ObjectPath -> BTIO ()
addDeviceRemovedListener adapter =
addBtOMListener remDevice
where
remDevice = pathCallback adapter $ \d -> do
2023-01-01 23:03:31 -05:00
old <- removeDevice d
2023-01-03 22:18:55 -05:00
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
2023-01-02 10:33:04 -05:00
when (adaptorHasDevice adapter d) $ beforeDisplay $ f d
pathCallback _ _ _ = return ()
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Adapter
2023-01-03 22:18:55 -05:00
initAdapter :: ObjectPath -> BTIO ()
initAdapter adapter = do
reply <- callGetPowered adapter
2023-01-01 22:03:17 -05:00
logInfo $ "initializing adapter at path " <> adapter_
-- TODO this could fail if the variant is something weird; the only
-- indication I will get is "NA"
2023-01-01 23:03:31 -05:00
putPowered $ fromSingletonVariant reply
2023-01-01 22:03:17 -05:00
where
adapter_ = displayWrapQuote $ displayObjectPath adapter
2022-12-30 16:58:30 -05:00
matchBTProperty
2023-01-03 22:18:55 -05:00
:: ( SafeClient c
, HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
=> ObjectPath
2022-12-30 16:58:30 -05:00
-> m (Maybe MatchRule)
2023-01-03 22:18:55 -05:00
matchBTProperty p = matchPropertyFull btBus (Just p)
2021-11-27 13:24:13 -05:00
withBTPropertyRule
2023-01-03 22:18:55 -05:00
:: ( 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)
2023-01-03 22:18:55 -05:00
withBTPropertyRule path update iface prop = do
res <- matchBTProperty path
case res of
2023-01-03 22:18:55 -05:00
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
2023-01-03 22:18:55 -05:00
addAdaptorListener :: ObjectPath -> BTIO (Maybe SignalHandler)
addAdaptorListener adaptor =
withBTPropertyRule adaptor procMatch adapterInterface adaptorPowered
2023-01-02 10:33:04 -05:00
where
procMatch = beforeDisplay . putPowered
2023-01-01 19:52:01 -05:00
callGetPowered
2023-01-03 22:18:55 -05:00
:: ( HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, SafeClient c
, MonadUnliftIO m
)
2023-01-01 19:52:01 -05:00
=> ObjectPath
-> m [Variant]
2022-12-30 14:58:23 -05:00
callGetPowered adapter =
callPropertyGet btBus adapter adapterInterface $
memberName_ $
T.unpack adaptorPowered
2021-11-23 18:28:38 -05:00
2023-01-01 23:03:31 -05:00
putPowered :: Maybe Bool -> BTIO ()
putPowered ds = modifyState $ \s -> return (s {btPowered = ds}, ())
2023-01-01 23:03:31 -05:00
readPowered :: BTIO (Maybe Bool)
readPowered = fmap btPowered $ readMVar =<< asks btState
adapterInterface :: InterfaceName
adapterInterface = interfaceName_ "org.bluez.Adapter1"
adaptorPowered :: T.Text
adaptorPowered = "Powered"
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Devices
2023-01-03 22:18:55 -05:00
addAndInitDevice :: ObjectPath -> BTIO ()
addAndInitDevice device = do
res <- addDeviceListener device
2023-01-01 21:36:16 -05:00
case res of
2023-01-01 22:03:17 -05:00
Just handler -> do
logInfo $ "initializing device at path " <> device_
2023-01-03 22:18:55 -05:00
initDevice handler device
2023-01-01 21:36:16 -05:00
Nothing -> logError $ "could not initialize device at path " <> device_
where
device_ = displayWrapQuote $ displayObjectPath device
2023-01-03 22:18:55 -05:00
initDevice :: SignalHandler -> ObjectPath -> BTIO ()
initDevice sh device = do
reply <- callGetConnected device
2022-12-30 14:58:23 -05:00
void $
2023-01-01 23:03:31 -05:00
insertDevice device $
2022-12-30 14:58:23 -05:00
BTDevice
{ btDevConnected = fromVariant =<< listToMaybe reply
, btDevSigHandler = sh
}
2023-01-03 22:18:55 -05:00
addDeviceListener :: ObjectPath -> BTIO (Maybe SignalHandler)
addDeviceListener device =
withBTPropertyRule device procMatch devInterface devConnected
2023-01-02 10:33:04 -05:00
where
procMatch = beforeDisplay . void . updateDevice device
2023-01-01 19:52:01 -05:00
callGetConnected
2023-01-03 22:18:55 -05:00
:: ( SafeClient c
, HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
2023-01-01 19:52:01 -05:00
=> ObjectPath
-> m [Variant]
2022-12-30 14:58:23 -05:00
callGetConnected p =
callPropertyGet btBus p devInterface $
memberName_ (T.unpack devConnected)
2023-01-01 23:03:31 -05:00
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)
2023-01-01 23:03:31 -05:00
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
2023-01-01 23:03:31 -05:00
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)
2023-01-01 23:03:31 -05:00
readDevices :: BTIO ConnectedDevices
readDevices = fmap btDevices $ readMVar =<< asks btState
devInterface :: InterfaceName
devInterface = interfaceName_ "org.bluez.Device1"
2021-11-25 00:12:00 -05:00
devConnected :: T.Text
devConnected = "Connected"