ENH make bluetooth match signals instead of polling

bin/xmobar.hs

@@ -11,7 +11,7 @@ module Main (main) where
 -- * Theme integration with xmonad (shared module imported below)
 -- * A custom Locks plugin from my own forked repo
 
-import           Control.Monad                                  (unless)
+import           Control.Monad
 
 import           Data.Either
 import           Data.List
@@ -42,7 +42,8 @@ import           XMonad.Hooks.DynamicLog
 import           XMonad.Internal.Command.Power                  (hasBattery)
 import           XMonad.Internal.DBus.Brightness.ClevoKeyboard
 import           XMonad.Internal.DBus.Brightness.IntelBacklight
-import           XMonad.Internal.DBus.Control
+import           XMonad.Internal.DBus.Common
+-- import           XMonad.Internal.DBus.Control
 import           XMonad.Internal.DBus.Screensaver               (ssSignalDep)
 import           XMonad.Internal.Dependency
 import           XMonad.Internal.Shell
@@ -162,7 +163,7 @@ btCmd :: CmdSpec
 btCmd = CmdSpec
   { csAlias = btAlias
   , csRunnable = Run
-    $ Bluetooth ("<fn=2>\xf293</fn>", T.fgColor, T.backdropFgColor) 5
+    $ Bluetooth ("<fn=2>\xf293</fn>", T.fgColor, T.backdropFgColor)
   }
 
 alsaCmd :: CmdSpec

lib/XMonad/Internal/DBus/Common.hs

@@ -6,12 +6,19 @@ module XMonad.Internal.DBus.Common
   , getDBusClient
   , withDBusClient
   , withDBusClient_
+  , withDBusClientConnection_
+  , matchProperty
   , xmonadBusName
+  , matchPropertyChanged
+  , SignalMatch(..)
+  , callPropertyGet
   ) where
 
 import           Control.Exception
 import           Control.Monad
 
+import qualified Data.Map.Strict   as M
+
 import           DBus
 import           DBus.Client
 
@@ -41,3 +48,47 @@ withDBusClient_ sys f = do
   client <- getDBusClient sys
   mapM_ f client
   mapM_ disconnect client
+
+withDBusClientConnection_ :: Bool -> (Client -> IO ()) -> IO ()
+withDBusClientConnection_ sys f = do
+  client <- getDBusClient sys
+  mapM_ f client
+
+propertyInterface :: InterfaceName
+propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
+
+propertySignal :: MemberName
+propertySignal = memberName_ "PropertiesChanged"
+
+matchProperty :: ObjectPath -> MatchRule
+matchProperty p = matchAny
+  -- NOTE: the sender for signals is usually the unique name (eg :X.Y) not the
+  -- requested name (eg "org.something.understandable"). If sender is included
+  -- here, likely nothing will match. Solution is to somehow get the unique
+  -- name, which I could do, but probably won't
+  { matchPath = Just p
+  , matchInterface = Just propertyInterface
+  , matchMember = Just propertySignal
+  }
+
+data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show)
+
+matchPropertyChanged :: InterfaceName -> String -> (Variant -> Maybe a)
+  -> [Variant] -> SignalMatch a
+matchPropertyChanged iface property f [i, body, _] =
+  let i' = (fromVariant i :: Maybe String)
+      b = toMap body in
+    case (i', b) of
+      (Just i'', Just b') -> if i'' == formatInterfaceName iface then
+        maybe NoMatch Match $ f =<< M.lookup property b'
+        else NoMatch
+      _                   -> Failure
+  where
+    toMap v = fromVariant v :: Maybe (M.Map String Variant)
+matchPropertyChanged _ _ _ _ = Failure
+
+callPropertyGet :: BusName -> ObjectPath -> InterfaceName -> String -> Client
+  -> IO [Variant]
+callPropertyGet bus path iface property client = either (const []) (:[])
+  <$> getProperty client (methodCall path iface $ memberName_ property)
+    { methodCallDestination = Just bus }

lib/Xmobar/Plugins/Bluetooth.hs

@@ -1,6 +1,3 @@
-{-# LANGUAGE LambdaCase        #-}
-{-# LANGUAGE OverloadedStrings #-}
-
 --------------------------------------------------------------------------------
 -- | Bluetooth plugin
 --
@@ -12,25 +9,21 @@ module Xmobar.Plugins.Bluetooth
   , btDep
   ) where
 
+import           Data.Maybe
 
 import           DBus
 import           DBus.Client
 
-import           XMonad.Hooks.DynamicLog    (xmobarColor)
+import           XMonad.Hooks.DynamicLog     (xmobarColor)
+import           XMonad.Internal.DBus.Common
 import           XMonad.Internal.Dependency
 import           Xmobar
 
-data Bluetooth = Bluetooth (String, String, String) Int
-    deriving (Read, Show)
+newtype Bluetooth = Bluetooth (String, String, String) deriving (Read, Show)
 
--- TODO match property signal here
-callGetPowered :: Client -> IO (Maybe Variant)
-callGetPowered client = either (const Nothing) Just
-  <$> getProperty client (methodCall btPath btInterface $ memberName_ btPowered)
-    { methodCallDestination = Just btBus }
 
 btInterface :: InterfaceName
-btInterface = "org.bluez.Adapter1"
+btInterface = interfaceName_ "org.bluez.Adapter1"
 
 -- weird that this is a string when introspecting but a member name when calling
 -- a method, not sure if it is supposed to work like that
@@ -38,11 +31,11 @@ btPowered :: String
 btPowered = "Powered"
 
 btBus :: BusName
-btBus = "org.bluez"
+btBus = busName_ "org.bluez"
 
 -- TODO this feels like something that shouldn't be hardcoded
 btPath :: ObjectPath
-btPath = "/org/bluez/hci0"
+btPath = objectPath_ "/org/bluez/hci0"
 
 btAlias :: String
 btAlias = "bluetooth"
@@ -50,15 +43,21 @@ btAlias = "bluetooth"
 btDep :: DBusDep
 btDep = Endpoint btBus btPath btInterface $ Property_ btPowered
 
+matchPowered :: [Variant] -> SignalMatch Bool
+matchPowered = matchPropertyChanged btInterface btPowered fromVariant
+
+callGetPowered :: Client -> IO [Variant]
+callGetPowered = callPropertyGet btBus btPath btInterface btPowered
+
 instance Exec Bluetooth where
-  alias (Bluetooth _ _) = btAlias
-  rate  (Bluetooth _ r) = r
-  run   (Bluetooth (text, colorOn, colorOff) _) = do
-    client <- connectSystem
-    reply <- callGetPowered client
-    disconnect client
-    return $ fmtState $ fromVariant =<< reply
+  alias (Bluetooth _) = btAlias
+  start (Bluetooth (text, colorOn, colorOff)) cb = do
+    withDBusClientConnection_ True $ \c -> do
+      reply <- callGetPowered c
+      cb $ maybe "N/A" chooseColor $ fromVariant =<< listToMaybe reply
+      addMatchCallback (matchProperty btPath) (procMatch cb . matchPowered) c
     where
-      fmtState = \case
-        Just s  -> xmobarColor (if s then colorOn else colorOff) "" text
-        Nothing -> "N/A"
+      procMatch f (Match on) = f $ chooseColor on
+      procMatch f Failure    = f "N/A"
+      procMatch _ NoMatch    = return ()
+      chooseColor state = xmobarColor (if state then colorOn else colorOff) "" text