ENH make bluetooth match signals instead of polling
This commit is contained in:
parent
78dd1ee5b7
commit
0fe36fcccb
|
@ -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
|
||||||
|
|
|
@ -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 }
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue