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

275 lines
8.4 KiB
Haskell
Raw Normal View History

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>".
--
2023-10-15 21:50:46 -04:00
-- 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
2023-10-15 21:50:46 -04:00
-- adapter changing. For now it should just get the first adaptor and only pay
-- attention to devices associated with it.
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
2023-10-15 21:50:46 -04:00
import qualified RIO.Set as S
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 =
withDBusClientConnection cb Nothing (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
2023-10-27 23:12:22 -04:00
-> NamedSysConnection
2023-01-01 23:03:31 -05:00
-> RIO SimpleApp ()
startAdapter is cs cb cl = do
state <- newMVar emptyState
2023-10-01 01:02:06 -04:00
let dpy cb' = displayIcon cb' (iconFormatter is cs)
mapRIO (PluginEnv cl state dpy cb) $ do
2023-01-03 22:18:55 -05:00
ot <- getBtObjectTree
2023-10-15 21:50:46 -04:00
case findAdaptor ot of
Nothing -> logError "could not find bluetooth adapter"
2023-10-15 21:50:46 -04:00
Just adaptor -> do
initAdapterState adaptor
initDevicesState adaptor ot
startAdaptorListener adaptor
startConnectedListener adaptor
2023-10-01 01:02:06 -04:00
pluginDisplay
--------------------------------------------------------------------------------
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
2023-10-01 01:02:06 -04:00
type BTIO = PluginIO BtState SysClient
2023-01-01 23:03:31 -05:00
data BtState = BtState
2023-10-15 21:50:46 -04:00
{ btDevices :: S.Set ObjectPath
, btPowered :: Maybe Bool
}
emptyState :: BtState
2022-12-30 14:58:23 -05:00
emptyState =
BtState
2023-10-15 21:50:46 -04:00
{ btDevices = S.empty
2022-12-30 14:58:23 -05:00
, btPowered = Nothing
}
2023-01-01 23:03:31 -05:00
readState :: BTIO (Maybe Bool, Bool)
readState = do
p <- readPowered
c <- readDevices
2023-10-15 21:50:46 -04:00
return (p, not $ null c)
modifyState :: (BtState -> BTIO (BtState, a)) -> BTIO a
modifyState f = do
2023-10-01 01:02:06 -04:00
m <- asks plugState
modifyMVar m f
2023-01-02 10:33:04 -05:00
beforeDisplay :: BTIO () -> BTIO ()
2023-10-01 01:02:06 -04:00
beforeDisplay f = f >> pluginDisplay
2023-01-02 10:33:04 -05:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Object manager
2023-10-15 21:50:46 -04:00
findAdaptor :: ObjectTree -> Maybe ObjectPath
findAdaptor = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys
2023-10-15 21:50:46 -04:00
-- | 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
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_ "/"
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Adapter
2023-10-15 21:50:46 -04:00
-- | Get powered state of adaptor and log the result
initAdapterState :: ObjectPath -> BTIO ()
initAdapterState adapter = do
2023-01-03 22:18:55 -05:00
reply <- callGetPowered adapter
2023-01-01 23:03:31 -05:00
putPowered $ fromSingletonVariant reply
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
2023-10-15 21:50:46 -04:00
-- | 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
2023-10-15 21:50:46 -04:00
Just rule -> void $ addMatchCallback rule callback
Nothing -> do
logError $
"could not add listener for prop "
2023-10-15 21:50:46 -04:00
<> displayMemberName adaptorPowered
<> " on path "
2023-10-15 21:50:46 -04:00
<> displayObjectPath adaptor
2023-01-02 10:33:04 -05:00
where
2023-10-15 21:50:46 -04:00
callback sig =
2023-10-27 23:12:22 -04:00
withNestedDBusClientConnection Nothing Nothing $
2023-10-15 21:50:46 -04:00
withSignalMatch procMatch $
matchPropertyChanged adaptorInterface adaptorPowered sig
2023-01-02 10:33:04 -05:00
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 =
2023-10-15 21:50:46 -04:00
callPropertyGet btBus adapter adaptorInterface 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)
2023-10-01 01:02:06 -04:00
readPowered = fmap btPowered $ readMVar =<< asks plugState
2023-10-15 21:50:46 -04:00
adaptorInterface :: InterfaceName
adaptorInterface = interfaceName_ "org.bluez.Adapter1"
2023-10-15 21:50:46 -04:00
adaptorPowered :: MemberName
adaptorPowered = "Powered"
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Devices
2023-10-15 21:50:46 -04:00
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"
2023-01-02 10:33:04 -05:00
where
2023-10-15 21:50:46 -04:00
adaptor_ = displayWrapQuote $ displayObjectPath adaptor
callback sig =
2023-10-27 23:12:22 -04:00
withNestedDBusClientConnection Nothing Nothing $ do
2023-10-15 21:50:46 -04:00
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)
2023-10-01 01:02:06 -04:00
readDevices = fmap btDevices $ readMVar =<< asks plugState
devInterface :: InterfaceName
devInterface = interfaceName_ "org.bluez.Device1"
2021-11-25 00:12:00 -05:00
2023-10-15 21:50:46 -04:00
devConnected :: MemberName
devConnected = "Connected"