388 lines
12 KiB
Haskell
388 lines
12 KiB
Haskell
{-# 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 "bluetooth" $ 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
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- 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"
|