ENH make bluetooth match signals instead of polling

This commit is contained in:
Nathan Dwarshuis 2021-11-24 00:21:18 -05:00
parent 78dd1ee5b7
commit 0fe36fcccb
3 changed files with 78 additions and 27 deletions

View File

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

View File

@ -6,12 +6,19 @@ module XMonad.Internal.DBus.Common
, getDBusClient , getDBusClient
, withDBusClient , withDBusClient
, withDBusClient_ , withDBusClient_
, withDBusClientConnection_
, matchProperty
, xmonadBusName , xmonadBusName
, matchPropertyChanged
, SignalMatch(..)
, callPropertyGet
) where ) where
import Control.Exception import Control.Exception
import Control.Monad import Control.Monad
import qualified Data.Map.Strict as M
import DBus import DBus
import DBus.Client import DBus.Client
@ -41,3 +48,47 @@ withDBusClient_ sys f = do
client <- getDBusClient sys client <- getDBusClient sys
mapM_ f client mapM_ f client
mapM_ disconnect 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 }

View File

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