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

289 lines
10 KiB
Haskell
Raw Normal View History

{-# LANGUAGE OverloadedStrings #-}
2020-04-01 22:06:00 -04:00
--------------------------------------------------------------------------------
-- | 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.
2020-04-01 22:06:00 -04:00
module Xmobar.Plugins.Bluetooth
( Bluetooth(..)
, btAlias
2021-11-23 18:28:38 -05:00
, btDep
) where
2020-03-21 01:18:38 -04:00
import Control.Concurrent.MVar
import Control.Monad
2022-07-09 17:44:14 -04:00
import Data.Internal.DBus
import Data.Internal.Dependency
import Data.List
import Data.List.Split
import qualified Data.Map as M
import Data.Maybe
2020-03-25 18:55:52 -04:00
import DBus
import DBus.Client
2020-03-21 01:18:38 -04:00
import qualified RIO.Text as T
import XMonad.Internal.DBus.Common
2021-06-19 00:54:01 -04:00
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
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 =
2022-07-09 17:08:10 -04:00
withDBusClientConnection cb $ startAdapter icons colors cb
2022-07-09 17:08:10 -04:00
startAdapter :: Icons -> Colors -> Callback -> SysClient -> IO ()
startAdapter is cs cb cl = do
ot <- getBtObjectTree cl
state <- newMVar emptyState
let display = displayIcon cb (iconFormatter is cs) state
forM_ (findAdapter ot) $ \adapter -> do
-- set up adapter
initAdapter state adapter cl
2021-11-27 13:24:13 -05:00
-- TODO this step could fail; at least warn the user...
void $ addAdaptorListener state display adapter cl
-- set up devices on the adapter (and listeners for adding/removing devices)
let devices = findDevices adapter ot
addDeviceAddedListener state display adapter cl
addDeviceRemovedListener state display adapter cl
forM_ devices $ \d -> addAndInitDevice state display d cl
-- after setting things up, show the icon based on the initialized state
display
--------------------------------------------------------------------------------
-- | 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)
displayIcon :: Callback -> IconFormatter -> MutableBtState -> IO ()
displayIcon callback formatter =
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
--------------------------------------------------------------------------------
-- | 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 BTDevice = BTDevice
{ btDevConnected :: Maybe Bool
, btDevSigHandler :: SignalHandler
}
type ConnectedDevices = M.Map ObjectPath BTDevice
data BtState = BtState
{ btDevices :: ConnectedDevices
, btPowered :: Maybe Bool
}
type MutableBtState = MVar BtState
emptyState :: BtState
emptyState = BtState
{ btDevices = M.empty
, btPowered = Nothing
}
readState :: MutableBtState -> IO (Maybe Bool, Bool)
readState state = do
p <- readPowered state
c <- readDevices state
return (p, anyDevicesConnected c)
--------------------------------------------------------------------------------
-- | 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 splitPath device of
[org, bluez, hciX, _] -> splitPath adaptor == [org, bluez, hciX]
_ -> False
splitPath :: ObjectPath -> [T.Text]
splitPath = fmap T.pack . splitOn "/" . dropWhile (=='/') . formatObjectPath
2022-07-09 17:08:10 -04:00
getBtObjectTree :: SysClient -> IO ObjectTree
2022-07-09 17:44:14 -04:00
getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath
2021-11-08 00:27:39 -05:00
2021-11-27 13:24:13 -05:00
btOMPath :: ObjectPath
btOMPath = objectPath_ "/"
2022-07-09 17:08:10 -04:00
addBtOMListener :: SignalCallback -> SysClient -> IO ()
2022-07-09 17:44:14 -04:00
addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc
2022-07-09 17:08:10 -04:00
addDeviceAddedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
addDeviceAddedListener state display adapter client =
2021-11-27 13:24:13 -05:00
addBtOMListener addDevice client
where
addDevice = pathCallback adapter display $ \d ->
addAndInitDevice state display d client
2020-03-21 14:30:27 -04:00
2022-07-09 17:08:10 -04:00
addDeviceRemovedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
addDeviceRemovedListener state display adapter sys =
addBtOMListener remDevice sys
where
remDevice = pathCallback adapter display $ \d -> do
old <- removeDevice state d
2022-07-09 17:08:10 -04:00
forM_ old $ removeMatch (toClient sys) . btDevSigHandler
pathCallback :: ObjectPath -> IO () -> (ObjectPath -> IO ()) -> SignalCallback
pathCallback adapter display f [device, _] = forM_ (fromVariant device) $ \d ->
when (adaptorHasDevice adapter d) $ f d >> display
pathCallback _ _ _ _ = return ()
--------------------------------------------------------------------------------
-- | Adapter
2022-07-09 17:08:10 -04:00
initAdapter :: MutableBtState -> ObjectPath -> SysClient -> IO ()
initAdapter state adapter client = do
reply <- callGetPowered adapter client
putPowered state $ fromSingletonVariant reply
2022-07-09 17:08:10 -04:00
matchBTProperty :: SysClient -> ObjectPath -> IO (Maybe MatchRule)
2022-07-09 17:44:14 -04:00
matchBTProperty sys p = matchPropertyFull sys btBus (Just p)
2021-11-27 13:24:13 -05:00
2022-07-09 17:08:10 -04:00
addAdaptorListener :: MutableBtState -> IO () -> ObjectPath -> SysClient
2021-11-27 13:24:13 -05:00
-> IO (Maybe SignalHandler)
2022-07-09 17:08:10 -04:00
addAdaptorListener state display adaptor sys = do
rule <- matchBTProperty sys adaptor
2022-07-09 17:44:14 -04:00
forM rule $ \r -> addMatchCallback r (procMatch . matchPowered) sys
where
procMatch = withSignalMatch $ \b -> putPowered state b >> display
2022-07-09 17:08:10 -04:00
callGetPowered :: ObjectPath -> SysClient -> IO [Variant]
2022-07-09 17:44:14 -04:00
callGetPowered adapter = callPropertyGet btBus adapter adapterInterface
$ memberName_ $ T.unpack adaptorPowered
2021-11-23 18:28:38 -05:00
matchPowered :: [Variant] -> SignalMatch Bool
matchPowered = matchPropertyChanged adapterInterface adaptorPowered
putPowered :: MutableBtState -> Maybe Bool -> IO ()
putPowered m ds = modifyMVar_ m (\s -> return s { btPowered = ds })
readPowered :: MutableBtState -> IO (Maybe Bool)
readPowered = fmap btPowered . readMVar
adapterInterface :: InterfaceName
adapterInterface = interfaceName_ "org.bluez.Adapter1"
adaptorPowered :: T.Text
adaptorPowered = "Powered"
--------------------------------------------------------------------------------
-- | Devices
2022-07-09 17:08:10 -04:00
addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
addAndInitDevice state display device client = do
sh <- addDeviceListener state display device client
2021-11-27 13:24:13 -05:00
-- TODO add some intelligent error messages here
forM_ sh $ \s -> initDevice state s device client
2022-07-09 17:08:10 -04:00
initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> SysClient -> IO ()
2022-07-09 17:44:14 -04:00
initDevice state sh device sys = do
reply <- callGetConnected device sys
void $ insertDevice state device $
BTDevice { btDevConnected = fromVariant =<< listToMaybe reply
, btDevSigHandler = sh
}
2022-07-09 17:08:10 -04:00
addDeviceListener :: MutableBtState -> IO () -> ObjectPath -> SysClient
2021-11-27 13:24:13 -05:00
-> IO (Maybe SignalHandler)
2022-07-09 17:44:14 -04:00
addDeviceListener state display device sys = do
rule <- matchBTProperty sys device
forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) sys
where
procMatch = withSignalMatch $ \c -> updateDevice state device c >> display
matchConnected :: [Variant] -> SignalMatch Bool
matchConnected = matchPropertyChanged devInterface devConnected
2022-07-09 17:44:14 -04:00
callGetConnected :: ObjectPath -> SysClient -> IO [Variant]
callGetConnected p = callPropertyGet btBus p devInterface
$ memberName_ (T.unpack devConnected)
insertDevice :: MutableBtState -> ObjectPath -> BTDevice -> IO Bool
insertDevice m device dev = modifyMVar m $ \s -> do
let new = M.insert device dev $ btDevices s
return (s { btDevices = new }, anyDevicesConnected new)
updateDevice :: MutableBtState -> ObjectPath -> Maybe Bool -> IO Bool
updateDevice m device status = modifyMVar m $ \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 :: MutableBtState -> ObjectPath -> IO (Maybe BTDevice)
removeDevice m device = modifyMVar m $ \s -> do
let devs = btDevices s
return (s { btDevices = M.delete device devs }, M.lookup device devs)
readDevices :: MutableBtState -> IO ConnectedDevices
readDevices = fmap btDevices . readMVar
devInterface :: InterfaceName
devInterface = interfaceName_ "org.bluez.Device1"
2021-11-25 00:12:00 -05:00
devConnected :: T.Text
devConnected = "Connected"