From 58b68f298ccb429b116dd15b87901f79c9a865a1 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sun, 15 Oct 2023 21:50:46 -0400 Subject: [PATCH] FIX bluetooth being dumb --- lib/Data/Internal/DBus.hs | 36 +++-- lib/Xmobar/Plugins/Bluetooth.hs | 271 ++++++++++---------------------- lib/Xmobar/Plugins/Common.hs | 16 ++ 3 files changed, 123 insertions(+), 200 deletions(-) diff --git a/lib/Data/Internal/DBus.hs b/lib/Data/Internal/DBus.hs index 241c230..144901a 100644 --- a/lib/Data/Internal/DBus.hs +++ b/lib/Data/Internal/DBus.hs @@ -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 diff --git a/lib/Xmobar/Plugins/Bluetooth.hs b/lib/Xmobar/Plugins/Bluetooth.hs index 37f3c76..1516f8d 100644 --- a/lib/Xmobar/Plugins/Bluetooth.hs +++ b/lib/Xmobar/Plugins/Bluetooth.hs @@ -7,28 +7,18 @@ -- Manager. The adapter is located at path "/org/bluez/hci" where X is -- usually 0, and each device is "/org/bluez/hci/". -- --- 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" diff --git a/lib/Xmobar/Plugins/Common.hs b/lib/Xmobar/Plugins/Common.hs index 3b47bc9..9771cec 100644 --- a/lib/Xmobar/Plugins/Common.hs +++ b/lib/Xmobar/Plugins/Common.hs @@ -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