FIX bluetooth being dumb

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, _] =
+matchPropertyChanged iface property [sigIface, sigValues, _] =
-  let i' = (fromVariant i :: Maybe T.Text)
+  let i = fromVariant sigIface :: Maybe T.Text
-      b = toMap body
+      v = fromVariant sigValues :: Maybe (M.Map T.Text Variant)
-   in case (i', b) of
+   in case (i, v) of
-        (Just i'', Just b') ->
+        (Just i', Just v') ->
-          if i'' == T.pack (formatInterfaceName iface)
+          if i' == interfaceNameT iface
-            then maybe NoMatch Match $ fromVariant =<< M.lookup property b'
+            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
 

lib/Xmobar/Plugins/Bluetooth.hs

@@ -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
+-- Simple and somewhat crude way to do this is to have two monitors, one
--- connected to it. The rough outline for this procedure:
+-- watching the powered state of the adaptor and one listening for connection
--- 1) get the adapter from the object manager
+-- changes. The former is easy since this is just one /org/bluez/hciX. For the
--- 2) get all devices associated with the adapter using the object interface
+-- latter, each 'Connected' property is embedded in each individual device path
--- 3) determine if the adapter is powered
+-- on `org.bluez.Device1', so just watch the entire bluez bus for property
--- 4) determine if any devices are connected
+-- changes and filter those that correspond to the aforementioned
--- 5) format the icon; powered vs not powered controls the color and connected
+-- interface/property. Track all this in a state which keeps the powered
---    vs not connected controls the icon (connected bluetooth symbol has two
+-- property and a running list of connected devices.
---    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.
+-- 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
+      Just adaptor -> do
-        -- set up adapter
+        initAdapterState adaptor
-        initAdapter adapter
+        initDevicesState adaptor ot
-        void $ addAdaptorListener adapter
+        startAdaptorListener adaptor
-        -- set up devices on the adapter (and listeners for adding/removing devices)
+        startConnectedListener adaptor
-        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
         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
+findAdaptor :: ObjectTree -> Maybe ObjectPath
-findAdapter = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys
+findAdaptor = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys
 
-findDevices :: ObjectPath -> ObjectTree -> [ObjectPath]
+-- | Search the object tree for devices which are in a connected state.
-findDevices adapter = filter (adaptorHasDevice adapter) . M.keys
+-- 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 ()
+-- | Get powered state of adaptor and log the result
-initAdapter adapter = do
+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
+-- | Start a listener that monitors changes to the powered state of an adaptor
-  :: IsVariant a
+startAdaptorListener :: ObjectPath -> BTIO ()
-  => FilePath
+startAdaptorListener adaptor = do
-  -> ObjectPath
+  res <- matchBTProperty adaptor
-  -> (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
   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_
+          <> displayObjectPath adaptor
-      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
   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 $
+  callPropertyGet btBus adapter adaptorInterface adaptorPowered
-    memberName_ $
-      T.unpack 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
+adaptorInterface :: InterfaceName
-adapterInterface = interfaceName_ "org.bluez.Adapter1"
+adaptorInterface = interfaceName_ "org.bluez.Adapter1"
 
-adaptorPowered :: T.Text
+adaptorPowered :: MemberName
 adaptorPowered = "Powered"
 
 --------------------------------------------------------------------------------
 -- Devices
 
-addAndInitDevice :: FilePath -> ObjectPath -> BTIO ()
+initDevicesState :: ObjectPath -> ObjectTree -> BTIO ()
-addAndInitDevice logpath device = do
+initDevicesState adaptor ot = do
-  res <- addDeviceListener logpath device
+  let devices = findConnectedDevices adaptor ot
-  case res of
+  modifyState $ \s -> return (s {btDevices = S.fromList devices}, ())
-    Just handler -> do
+
-      logInfo $ "initializing device at path " <> device_
+startConnectedListener :: ObjectPath -> BTIO ()
-      initDevice handler device
+startConnectedListener adaptor = do
-    Nothing -> logError $ "could not initialize device at path " <> device_
+  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 ()
+readDevices :: BTIO (S.Set ObjectPath)
-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 = fmap btDevices $ readMVar =<< asks plugState
 
 devInterface :: InterfaceName
 devInterface = interfaceName_ "org.bluez.Device1"
 
-devConnected :: T.Text
+devConnected :: MemberName
 devConnected = "Connected"

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