FIX bluetooth being dumb
This commit is contained in:
parent
98e0a2943d
commit
58b68f298c
|
|
@ -37,6 +37,10 @@ module Data.Internal.DBus
|
|||
, displayMemberName
|
||||
, displayInterfaceName
|
||||
, displayWrapQuote
|
||||
, busNameT
|
||||
, interfaceNameT
|
||||
, memberNameT
|
||||
, objectPathT
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -326,20 +330,20 @@ withSignalMatch _ NoMatch = return ()
|
|||
matchPropertyChanged
|
||||
:: IsVariant a
|
||||
=> InterfaceName
|
||||
-> T.Text
|
||||
-> MemberName
|
||||
-> [Variant]
|
||||
-> SignalMatch a
|
||||
matchPropertyChanged iface property [i, body, _] =
|
||||
let i' = (fromVariant i :: Maybe T.Text)
|
||||
b = toMap body
|
||||
in case (i', b) of
|
||||
(Just i'', Just b') ->
|
||||
if i'' == T.pack (formatInterfaceName iface)
|
||||
then maybe NoMatch Match $ fromVariant =<< M.lookup property b'
|
||||
matchPropertyChanged iface property [sigIface, sigValues, _] =
|
||||
let i = fromVariant sigIface :: Maybe T.Text
|
||||
v = fromVariant sigValues :: Maybe (M.Map T.Text Variant)
|
||||
in case (i, v) of
|
||||
(Just i', Just v') ->
|
||||
if i' == interfaceNameT iface
|
||||
then
|
||||
maybe NoMatch Match $
|
||||
fromVariant =<< M.lookup (memberNameT property) v'
|
||||
else NoMatch
|
||||
_ -> Failure
|
||||
where
|
||||
toMap v = fromVariant v :: Maybe (M.Map T.Text Variant)
|
||||
matchPropertyChanged _ _ _ = Failure
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -463,6 +467,18 @@ exportPair path toIface cl = (up, down)
|
|||
--------------------------------------------------------------------------------
|
||||
-- logging helpers
|
||||
|
||||
busNameT :: BusName -> T.Text
|
||||
busNameT = T.pack . formatBusName
|
||||
|
||||
objectPathT :: ObjectPath -> T.Text
|
||||
objectPathT = T.pack . formatObjectPath
|
||||
|
||||
interfaceNameT :: InterfaceName -> T.Text
|
||||
interfaceNameT = T.pack . formatInterfaceName
|
||||
|
||||
memberNameT :: MemberName -> T.Text
|
||||
memberNameT = T.pack . formatMemberName
|
||||
|
||||
displayBusName :: BusName -> Utf8Builder
|
||||
displayBusName = displayBytesUtf8 . BC.pack . formatBusName
|
||||
|
||||
|
|
|
|||
|
|
@ -7,28 +7,18 @@
|
|||
-- 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)
|
||||
-- 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
|
||||
-- adapter changing.
|
||||
-- adapter changing. For now it should just get the first adaptor and only pay
|
||||
-- attention to devices associated with it.
|
||||
|
||||
module Xmobar.Plugins.Bluetooth
|
||||
( Bluetooth (..)
|
||||
|
|
@ -45,6 +35,7 @@ import RIO
|
|||
import RIO.FilePath
|
||||
import RIO.List
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.Set as S
|
||||
import qualified RIO.Text as T
|
||||
import XMonad.Internal.DBus.Common
|
||||
import Xmobar
|
||||
|
|
@ -76,28 +67,15 @@ startAdapter is cs cb cl = do
|
|||
let dpy cb' = displayIcon cb' (iconFormatter is cs)
|
||||
mapRIO (PluginEnv cl state dpy cb) $ do
|
||||
ot <- getBtObjectTree
|
||||
case findAdapter ot of
|
||||
case findAdaptor 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 (deviceLogFile d) d
|
||||
-- after setting things up, show the icon based on the initialized state
|
||||
Just adaptor -> do
|
||||
initAdapterState adaptor
|
||||
initDevicesState adaptor ot
|
||||
startAdaptorListener adaptor
|
||||
startConnectedListener adaptor
|
||||
pluginDisplay
|
||||
|
||||
deviceLogFile :: ObjectPath -> FilePath
|
||||
deviceLogFile =
|
||||
T.unpack
|
||||
. T.append "bluetooth"
|
||||
. T.map (\c -> if c == '/' then '_' else c)
|
||||
. T.pack
|
||||
. formatObjectPath
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Icon Display
|
||||
--
|
||||
|
|
@ -121,30 +99,18 @@ iconFormatter (iconConn, iconDisc) cs powered connected =
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
-- 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.
|
||||
|
||||
type BTIO = PluginIO BtState SysClient
|
||||
|
||||
data BTDevice = BTDevice
|
||||
{ btDevConnected :: Maybe Bool
|
||||
, btDevSigHandler :: SignalHandler
|
||||
}
|
||||
|
||||
type ConnectedDevices = M.Map ObjectPath BTDevice
|
||||
|
||||
data BtState = BtState
|
||||
{ btDevices :: ConnectedDevices
|
||||
{ btDevices :: S.Set ObjectPath
|
||||
, btPowered :: Maybe Bool
|
||||
}
|
||||
|
||||
emptyState :: BtState
|
||||
emptyState =
|
||||
BtState
|
||||
{ btDevices = M.empty
|
||||
{ btDevices = S.empty
|
||||
, btPowered = Nothing
|
||||
}
|
||||
|
||||
|
|
@ -152,7 +118,7 @@ readState :: BTIO (Maybe Bool, Bool)
|
|||
readState = do
|
||||
p <- readPowered
|
||||
c <- readDevices
|
||||
return (p, anyDevicesConnected c)
|
||||
return (p, not $ null c)
|
||||
|
||||
modifyState :: (BtState -> BTIO (BtState, a)) -> BTIO a
|
||||
modifyState f = do
|
||||
|
|
@ -165,11 +131,20 @@ beforeDisplay f = f >> pluginDisplay
|
|||
--------------------------------------------------------------------------------
|
||||
-- Object manager
|
||||
|
||||
findAdapter :: ObjectTree -> Maybe ObjectPath
|
||||
findAdapter = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys
|
||||
findAdaptor :: ObjectTree -> Maybe ObjectPath
|
||||
findAdaptor = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys
|
||||
|
||||
findDevices :: ObjectPath -> ObjectTree -> [ObjectPath]
|
||||
findDevices adapter = filter (adaptorHasDevice adapter) . M.keys
|
||||
-- | 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
|
||||
adaptorHasDevice adaptor device = case splitPathNoRoot device of
|
||||
|
|
@ -192,49 +167,14 @@ 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 (deviceLogFile d) d
|
||||
|
||||
addDeviceRemovedListener :: ObjectPath -> BTIO ()
|
||||
addDeviceRemovedListener adapter =
|
||||
addBtOMListener remDevice
|
||||
where
|
||||
remDevice = pathCallback adapter $ \d -> do
|
||||
old <- removeDevice d
|
||||
cl <- asks plugClient
|
||||
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
|
||||
-- | Get powered state of adaptor and log the result
|
||||
initAdapterState :: ObjectPath -> BTIO ()
|
||||
initAdapterState 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
|
||||
|
|
@ -247,42 +187,23 @@ matchBTProperty
|
|||
-> m (Maybe MatchRule)
|
||||
matchBTProperty p = matchPropertyFull btBus (Just p)
|
||||
|
||||
withBTPropertyRule
|
||||
:: IsVariant a
|
||||
=> FilePath
|
||||
-> ObjectPath
|
||||
-> (Maybe a -> BTIO ())
|
||||
-> InterfaceName
|
||||
-> T.Text
|
||||
-> BTIO (Maybe SignalHandler)
|
||||
withBTPropertyRule logpath path update iface prop = do
|
||||
dpy <- asks plugDisplay
|
||||
s <- asks plugState
|
||||
cb <- asks plugCallback
|
||||
res <- matchBTProperty path
|
||||
-- | 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
|
||||
Just rule -> Just <$> addMatchCallback rule (callback cb s dpy)
|
||||
Just rule -> void $ addMatchCallback rule callback
|
||||
Nothing -> do
|
||||
logError $
|
||||
"could not add listener for prop "
|
||||
<> prop_
|
||||
<> displayMemberName adaptorPowered
|
||||
<> " on path "
|
||||
<> path_
|
||||
return Nothing
|
||||
where
|
||||
callback cb s dpy sig = withDBusClientConnection cb (Just logpath) $ \c' ->
|
||||
mapRIO (PluginEnv c' s dpy cb) $
|
||||
signalToUpdate $
|
||||
matchConnected sig
|
||||
path_ = displayObjectPath path
|
||||
prop_ = Utf8Builder $ encodeUtf8Builder prop
|
||||
signalToUpdate = withSignalMatch update
|
||||
matchConnected = matchPropertyChanged iface prop
|
||||
|
||||
addAdaptorListener :: ObjectPath -> BTIO (Maybe SignalHandler)
|
||||
addAdaptorListener adaptor =
|
||||
withBTPropertyRule "bluetooth-adaptor" adaptor procMatch adapterInterface adaptorPowered
|
||||
<> displayObjectPath adaptor
|
||||
where
|
||||
callback sig =
|
||||
withNestedDBusClientConnection Nothing $
|
||||
withSignalMatch procMatch $
|
||||
matchPropertyChanged adaptorInterface adaptorPowered sig
|
||||
procMatch = beforeDisplay . putPowered
|
||||
|
||||
callGetPowered
|
||||
|
|
@ -295,9 +216,7 @@ callGetPowered
|
|||
=> ObjectPath
|
||||
-> m [Variant]
|
||||
callGetPowered adapter =
|
||||
callPropertyGet btBus adapter adapterInterface $
|
||||
memberName_ $
|
||||
T.unpack adaptorPowered
|
||||
callPropertyGet btBus adapter adaptorInterface adaptorPowered
|
||||
|
||||
putPowered :: Maybe Bool -> BTIO ()
|
||||
putPowered ds = modifyState $ \s -> return (s {btPowered = ds}, ())
|
||||
|
|
@ -305,78 +224,50 @@ putPowered ds = modifyState $ \s -> return (s {btPowered = ds}, ())
|
|||
readPowered :: BTIO (Maybe Bool)
|
||||
readPowered = fmap btPowered $ readMVar =<< asks plugState
|
||||
|
||||
adapterInterface :: InterfaceName
|
||||
adapterInterface = interfaceName_ "org.bluez.Adapter1"
|
||||
adaptorInterface :: InterfaceName
|
||||
adaptorInterface = interfaceName_ "org.bluez.Adapter1"
|
||||
|
||||
adaptorPowered :: T.Text
|
||||
adaptorPowered :: MemberName
|
||||
adaptorPowered = "Powered"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Devices
|
||||
|
||||
addAndInitDevice :: FilePath -> ObjectPath -> BTIO ()
|
||||
addAndInitDevice logpath device = do
|
||||
res <- addDeviceListener logpath 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_
|
||||
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"
|
||||
where
|
||||
device_ = displayWrapQuote $ displayObjectPath device
|
||||
adaptor_ = displayWrapQuote $ displayObjectPath adaptor
|
||||
callback sig =
|
||||
withNestedDBusClientConnection Nothing $ do
|
||||
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}, ())
|
||||
|
||||
initDevice :: SignalHandler -> ObjectPath -> BTIO ()
|
||||
initDevice sh device = do
|
||||
reply <- callGetConnected device
|
||||
void $
|
||||
insertDevice device $
|
||||
BTDevice
|
||||
{ btDevConnected = fromVariant =<< listToMaybe reply
|
||||
, btDevSigHandler = sh
|
||||
}
|
||||
|
||||
addDeviceListener :: FilePath -> ObjectPath -> BTIO (Maybe SignalHandler)
|
||||
addDeviceListener logpath device =
|
||||
withBTPropertyRule logpath 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 :: BTIO (S.Set ObjectPath)
|
||||
readDevices = fmap btDevices $ readMVar =<< asks plugState
|
||||
|
||||
devInterface :: InterfaceName
|
||||
devInterface = interfaceName_ "org.bluez.Device1"
|
||||
|
||||
devConnected :: T.Text
|
||||
devConnected :: MemberName
|
||||
devConnected = "Connected"
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@ module Xmobar.Plugins.Common
|
|||
, procSignalMatch
|
||||
, na
|
||||
, fromSingletonVariant
|
||||
, withNestedDBusClientConnection
|
||||
, withDBusClientConnection
|
||||
, Callback
|
||||
, Colors (..)
|
||||
|
|
@ -109,3 +110,18 @@ withDBusClientConnection cb logfile f =
|
|||
withLogFunc logOpts $ \lf -> do
|
||||
env <- mkSimpleApp lf Nothing
|
||||
runRIO env $ displayMaybe' cb f =<< getDBusClient
|
||||
|
||||
-- | Run a plugin action with a new DBus client and logfile path.
|
||||
-- This is necessary for DBus callbacks which run in separate threads, which
|
||||
-- will usually fire when the parent thread already exited and killed off its
|
||||
-- DBus connection and closed its logfile.
|
||||
withNestedDBusClientConnection
|
||||
:: (MonadUnliftIO m, SafeClient c, MonadReader (PluginEnv s c) m)
|
||||
=> Maybe FilePath
|
||||
-> PluginIO s c ()
|
||||
-> m ()
|
||||
withNestedDBusClientConnection logfile f = do
|
||||
dpy <- asks plugDisplay
|
||||
s <- asks plugState
|
||||
cb <- asks plugCallback
|
||||
withDBusClientConnection cb logfile $ \c -> mapRIO (PluginEnv c s dpy cb) f
|
||||
|
|
|
|||
Loading…
Reference in New Issue