diff --git a/bin/xmobar.hs b/bin/xmobar.hs
index 0f3d0af..2af40c9 100644
--- a/bin/xmobar.hs
+++ b/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 ("\xf293", T.fgColor, T.backdropFgColor) 5
+ $ Bluetooth ("\xf293", T.fgColor, T.backdropFgColor)
}
alsaCmd :: CmdSpec
diff --git a/lib/XMonad/Internal/DBus/Common.hs b/lib/XMonad/Internal/DBus/Common.hs
index a4d5666..1e006cb 100644
--- a/lib/XMonad/Internal/DBus/Common.hs
+++ b/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 }
diff --git a/lib/Xmobar/Plugins/Bluetooth.hs b/lib/Xmobar/Plugins/Bluetooth.hs
index 308a3ee..d9c54b5 100644
--- a/lib/Xmobar/Plugins/Bluetooth.hs
+++ b/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