ENH use busname when matching signal

This commit is contained in:
Nathan Dwarshuis 2021-11-27 13:24:13 -05:00
parent b9ede93e98
commit 9e4589cc98
10 changed files with 158 additions and 108 deletions

View File

@ -4,10 +4,11 @@
module DBus.Internal module DBus.Internal
( addMatchCallback ( addMatchCallback
, getDBusClient , getDBusClient
, fromDBusClient
, withDBusClient , withDBusClient
, withDBusClient_ , withDBusClient_
, matchProperty , matchProperty
, matchProperty' , matchPropertyFull
, matchPropertyChanged , matchPropertyChanged
, SignalMatch(..) , SignalMatch(..)
, SignalCallback , SignalCallback
@ -16,12 +17,15 @@ module DBus.Internal
, callPropertyGet , callPropertyGet
, callMethod , callMethod
, callMethod' , callMethod'
, methodCallBus
, callGetManagedObjects , callGetManagedObjects
, ObjectTree , ObjectTree
, getManagedObjects , getManagedObjects
, omInterface , omInterface
, addInterfaceAddedListener , addInterfaceAddedListener
, addInterfaceRemovedListener , addInterfaceRemovedListener
, fromSingletonVariant
, bodyToMaybe
) where ) where
import Control.Exception import Control.Exception
@ -44,9 +48,33 @@ callMethod' cl = fmap (bimap methodErrorMessage methodReturnBody) . call cl
callMethod :: Client -> BusName -> ObjectPath -> InterfaceName -> MemberName callMethod :: Client -> BusName -> ObjectPath -> InterfaceName -> MemberName
-> IO MethodBody -> IO MethodBody
callMethod client bus path iface mem = callMethod client bus path iface = callMethod' client . methodCallBus bus path iface
callMethod' client (methodCall path iface mem)
{ methodCallDestination = Just bus } methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall
methodCallBus b p i m = (methodCall p i m)
{ methodCallDestination = Just b }
--------------------------------------------------------------------------------
-- | Bus names
dbusInterface :: InterfaceName
dbusInterface = interfaceName_ "org.freedesktop.DBus"
callGetNameOwner :: Client -> BusName -> IO (Maybe BusName)
callGetNameOwner client name = bodyToMaybe <$> callMethod' client mc
where
mc = (methodCallBus dbusName dbusPath dbusInterface mem)
{ methodCallBody = [toVariant name] }
mem = memberName_ "GetNameOwner"
--------------------------------------------------------------------------------
-- | Variant parsing
fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a
fromSingletonVariant = fromVariant <=< listToMaybe
bodyToMaybe :: IsVariant a => MethodBody -> Maybe a
bodyToMaybe = either (const Nothing) fromSingletonVariant
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Signals -- | Signals
@ -56,6 +84,20 @@ type SignalCallback = [Variant] -> IO ()
addMatchCallback :: MatchRule -> SignalCallback -> Client -> IO SignalHandler addMatchCallback :: MatchRule -> SignalCallback -> Client -> IO SignalHandler
addMatchCallback rule cb client = addMatch client rule $ cb . signalBody addMatchCallback rule cb client = addMatch client rule $ cb . signalBody
matchSignal :: Maybe BusName -> Maybe ObjectPath -> Maybe InterfaceName
-> Maybe MemberName -> MatchRule
matchSignal b p i m = matchAny
{ matchPath = p
, matchSender = b
, matchInterface = i
, matchMember = m
}
matchSignalFull :: Client -> BusName -> Maybe ObjectPath -> Maybe InterfaceName
-> Maybe MemberName -> IO (Maybe MatchRule)
matchSignalFull client b p i m =
fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Properties -- | Properties
@ -65,26 +107,18 @@ propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
propertySignal :: MemberName propertySignal :: MemberName
propertySignal = memberName_ "PropertiesChanged" propertySignal = memberName_ "PropertiesChanged"
callPropertyGet :: BusName -> ObjectPath -> InterfaceName -> String -> Client callPropertyGet :: BusName -> ObjectPath -> InterfaceName -> MemberName -> Client
-> IO [Variant] -> IO [Variant]
callPropertyGet bus path iface property client = either (const []) (:[]) callPropertyGet bus path iface property client = fmap (either (const []) (:[]))
<$> getProperty client (methodCall path iface $ memberName_ property) $ getProperty client $ methodCallBus bus path iface property
{ methodCallDestination = Just bus }
-- TODO actually get the real busname when using this (will involve IO) matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule
matchProperty' :: Maybe ObjectPath -> MatchRule matchProperty b p =
matchProperty' p = matchAny matchSignal b p (Just propertyInterface) (Just propertySignal)
-- 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 = p
, matchInterface = Just propertyInterface
, matchMember = Just propertySignal
}
matchProperty :: ObjectPath -> MatchRule matchPropertyFull :: Client -> BusName -> Maybe ObjectPath -> IO (Maybe MatchRule)
matchProperty = matchProperty' . Just matchPropertyFull client b p =
matchSignalFull client b p (Just propertyInterface) (Just propertySignal)
data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show) data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show)
@ -117,18 +151,19 @@ getDBusClient sys = do
Left e -> putStrLn (clientErrorMessage e) >> return Nothing Left e -> putStrLn (clientErrorMessage e) >> return Nothing
Right c -> return $ Just c Right c -> return $ Just c
withDBusClient :: Bool -> (Client -> a) -> IO (Maybe a) withDBusClient :: Bool -> (Client -> IO a) -> IO (Maybe a)
withDBusClient sys f = do withDBusClient sys f = do
client <- getDBusClient sys client <- getDBusClient sys
let r = f <$> client forM client $ \c -> do
mapM_ disconnect client r <- f c
disconnect c
return r return r
withDBusClient_ :: Bool -> (Client -> IO ()) -> IO () withDBusClient_ :: Bool -> (Client -> IO ()) -> IO ()
withDBusClient_ sys f = do withDBusClient_ sys = void . withDBusClient sys
client <- getDBusClient sys
mapM_ f client fromDBusClient :: Bool -> (Client -> a) -> IO (Maybe a)
mapM_ disconnect client fromDBusClient sys f = withDBusClient sys (return . f)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Object Manager -- | Object Manager
@ -141,30 +176,29 @@ omInterface = interfaceName_ "org.freedesktop.DBus.ObjectManager"
getManagedObjects :: MemberName getManagedObjects :: MemberName
getManagedObjects = memberName_ "GetManagedObjects" getManagedObjects = memberName_ "GetManagedObjects"
callGetManagedObjects :: Client -> BusName -> ObjectPath -> IO ObjectTree
callGetManagedObjects client bus path =
either (const M.empty) (fromMaybe M.empty . (fromVariant <=< listToMaybe))
<$> callMethod client bus path omInterface getManagedObjects
omInterfacesAdded :: MemberName omInterfacesAdded :: MemberName
omInterfacesAdded = memberName_ "InterfacesAdded" omInterfacesAdded = memberName_ "InterfacesAdded"
omInterfacesRemoved :: MemberName omInterfacesRemoved :: MemberName
omInterfacesRemoved = memberName_ "InterfacesRemoved" omInterfacesRemoved = memberName_ "InterfacesRemoved"
-- TODO add busname back to this (use NameGetOwner on org.freedesktop.DBus) callGetManagedObjects :: Client -> BusName -> ObjectPath -> IO ObjectTree
addInterfaceChangedListener :: MemberName -> ObjectPath -> SignalCallback callGetManagedObjects client bus path =
-> Client -> IO () either (const M.empty) (fromMaybe M.empty . fromSingletonVariant)
addInterfaceChangedListener prop path = fmap void . addMatchCallback rule <$> callMethod client bus path omInterface getManagedObjects
where
rule = matchAny
{ matchPath = Just path
, matchInterface = Just omInterface
, matchMember = Just prop
}
addInterfaceAddedListener :: ObjectPath -> SignalCallback -> Client -> IO () addInterfaceChangedListener :: BusName -> MemberName -> ObjectPath
addInterfaceAddedListener = addInterfaceChangedListener omInterfacesAdded -> SignalCallback -> Client -> IO (Maybe SignalHandler)
addInterfaceChangedListener bus prop path sc client = do
rule <- matchSignalFull client bus (Just path) (Just omInterface) (Just prop)
forM rule $ \r -> addMatchCallback r sc client
addInterfaceRemovedListener :: ObjectPath -> SignalCallback -> Client -> IO () addInterfaceAddedListener :: BusName -> ObjectPath -> SignalCallback -> Client
addInterfaceRemovedListener = addInterfaceChangedListener omInterfacesRemoved -> IO (Maybe SignalHandler)
addInterfaceAddedListener bus =
addInterfaceChangedListener bus omInterfacesAdded
addInterfaceRemovedListener :: BusName -> ObjectPath -> SignalCallback -> Client
-> IO (Maybe SignalHandler)
addInterfaceRemovedListener bus =
addInterfaceChangedListener bus omInterfacesRemoved

View File

@ -62,11 +62,10 @@ brightnessControls bc client =
where where
cb = callBacklight client bc cb = callBacklight client bc
-- TODO not dry
callGetBrightness :: Num c => BrightnessConfig a b -> Client -> IO (Maybe c) callGetBrightness :: Num c => BrightnessConfig a b -> Client -> IO (Maybe c)
callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client = do callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client =
reply <- callMethod client xmonadBusName p i memGet either (const Nothing) bodyGetBrightness
return $ either (const Nothing) bodyGetBrightness reply <$> callMethod client xmonadBusName p i memGet
signalDep :: BrightnessConfig a b -> DBusDep signalDep :: BrightnessConfig a b -> DBusDep
signalDep BrightnessConfig { bcPath = p, bcInterface = i } = signalDep BrightnessConfig { bcPath = p, bcInterface = i } =
@ -76,6 +75,7 @@ matchSignal :: Num c => BrightnessConfig a b -> (Maybe c -> IO ()) -> Client ->
matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
void . addMatchCallback brMatcher (cb . bodyGetBrightness) void . addMatchCallback brMatcher (cb . bodyGetBrightness)
where where
-- TODO add busname to this
brMatcher = matchAny brMatcher = matchAny
{ matchPath = Just p { matchPath = Just p
, matchInterface = Just i , matchInterface = Just i
@ -128,7 +128,8 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur =
where where
sig = signal p i memCur sig = signal p i memCur
callBacklight :: Maybe Client -> BrightnessConfig a b -> String -> MemberName -> FeatureIO callBacklight :: Maybe Client -> BrightnessConfig a b -> String -> MemberName
-> FeatureIO
callBacklight client BrightnessConfig { bcPath = p callBacklight client BrightnessConfig { bcPath = p
, bcInterface = i , bcInterface = i
, bcName = n } controlName m = , bcName = n } controlName m =

View File

@ -11,11 +11,11 @@ import DBus.Client
import Xmobar.Plugins.Common import Xmobar.Plugins.Common
startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> Client -> IO ()) startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> Client -> IO ())
-> (Client -> IO (Maybe a)) -> String -> (String -> IO ()) -> IO () -> (Client -> IO (Maybe a)) -> String -> Callback -> IO ()
startBacklight matchSignal callGetBrightness icon cb = do startBacklight matchSignal callGetBrightness icon cb = do
withDBusClientConnection False cb $ \c -> do withDBusClientConnection False cb $ \c -> do
matchSignal (cb . formatBrightness) c matchSignal display c
cb . formatBrightness =<< callGetBrightness c display =<< callGetBrightness c
where where
formatBrightness = maybe na $ formatBrightness b = return $ icon ++ show (round b :: Integer) ++ "%"
\b -> icon ++ show (round b :: Integer) ++ "%" display = displayMaybe cb formatBrightness

View File

@ -56,7 +56,7 @@ btAlias :: String
btAlias = "bluetooth" btAlias = "bluetooth"
btDep :: DBusDep btDep :: DBusDep
btDep = Endpoint btBus btOmPath omInterface $ Method_ getManagedObjects btDep = Endpoint btBus btOMPath omInterface $ Method_ getManagedObjects
data Bluetooth = Bluetooth Icons Colors deriving (Read, Show) data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
@ -73,7 +73,8 @@ startAdapter is cs cb cl = do
forM_ (findAdapter ot) $ \adapter -> do forM_ (findAdapter ot) $ \adapter -> do
-- set up adapter -- set up adapter
initAdapter state adapter cl initAdapter state adapter cl
addAdaptorListener state display adapter cl -- TODO this step could fail; at least warn the user...
void $ addAdaptorListener state display adapter cl
-- set up devices on the adapter (and listeners for adding/removing devices) -- set up devices on the adapter (and listeners for adding/removing devices)
let devices = findDevices adapter ot let devices = findDevices adapter ot
addDeviceAddedListener state display adapter cl addDeviceAddedListener state display adapter cl
@ -157,24 +158,27 @@ splitPath :: ObjectPath -> [String]
splitPath = splitOn "/" . dropWhile (=='/') . formatObjectPath splitPath = splitOn "/" . dropWhile (=='/') . formatObjectPath
getBtObjectTree :: Client -> IO ObjectTree getBtObjectTree :: Client -> IO ObjectTree
getBtObjectTree client = callGetManagedObjects client btBus btOmPath getBtObjectTree client = callGetManagedObjects client btBus btOMPath
btBus :: BusName btBus :: BusName
btBus = busName_ "org.bluez" btBus = busName_ "org.bluez"
btOmPath :: ObjectPath btOMPath :: ObjectPath
btOmPath = objectPath_ "/" btOMPath = objectPath_ "/"
addBtOMListener :: SignalCallback -> Client -> IO ()
addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc
addDeviceAddedListener :: MutableBtState -> IO () -> ObjectPath -> Client -> IO () addDeviceAddedListener :: MutableBtState -> IO () -> ObjectPath -> Client -> IO ()
addDeviceAddedListener state display adapter client = addDeviceAddedListener state display adapter client =
addInterfaceAddedListener btOmPath addDevice client addBtOMListener addDevice client
where where
addDevice = pathCallback adapter display $ \d -> addDevice = pathCallback adapter display $ \d ->
addAndInitDevice state display d client addAndInitDevice state display d client
addDeviceRemovedListener :: MutableBtState -> IO () -> ObjectPath -> Client -> IO () addDeviceRemovedListener :: MutableBtState -> IO () -> ObjectPath -> Client -> IO ()
addDeviceRemovedListener state display adapter client = addDeviceRemovedListener state display adapter client =
addInterfaceRemovedListener btOmPath remDevice client addBtOMListener remDevice client
where where
remDevice = pathCallback adapter display $ \d -> do remDevice = pathCallback adapter display $ \d -> do
old <- removeDevice state d old <- removeDevice state d
@ -193,16 +197,20 @@ initAdapter state adapter client = do
reply <- callGetPowered adapter client reply <- callGetPowered adapter client
putPowered state $ fromSingletonVariant reply putPowered state $ fromSingletonVariant reply
addAdaptorListener :: MutableBtState -> IO () -> ObjectPath -> Client -> IO () matchBTProperty :: Client -> ObjectPath -> IO (Maybe MatchRule)
addAdaptorListener state display adaptor = matchBTProperty client p = matchPropertyFull client btBus (Just p)
void . addMatchCallback rule (procMatch . matchPowered)
addAdaptorListener :: MutableBtState -> IO () -> ObjectPath -> Client
-> IO (Maybe SignalHandler)
addAdaptorListener state display adaptor client = do
rule <- matchBTProperty client adaptor
forM rule $ \r -> addMatchCallback r (procMatch . matchPowered) client
where where
rule = matchProperty adaptor
procMatch = withSignalMatch $ \b -> putPowered state b >> display procMatch = withSignalMatch $ \b -> putPowered state b >> display
callGetPowered :: ObjectPath -> Client -> IO [Variant] callGetPowered :: ObjectPath -> Client -> IO [Variant]
callGetPowered adapter = callGetPowered adapter =
callPropertyGet btBus adapter adapterInterface adaptorPowered callPropertyGet btBus adapter adapterInterface $ memberName_ adaptorPowered
matchPowered :: [Variant] -> SignalMatch Bool matchPowered :: [Variant] -> SignalMatch Bool
matchPowered = matchPropertyChanged adapterInterface adaptorPowered matchPowered = matchPropertyChanged adapterInterface adaptorPowered
@ -225,7 +233,8 @@ adaptorPowered = "Powered"
addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> Client -> IO () addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> Client -> IO ()
addAndInitDevice state display device client = do addAndInitDevice state display device client = do
sh <- addDeviceListener state display device client sh <- addDeviceListener state display device client
initDevice state sh device client -- TODO add some intelligent error messages here
forM_ sh $ \s -> initDevice state s device client
initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> Client -> IO () initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> Client -> IO ()
initDevice state sh device client = do initDevice state sh device client = do
@ -235,18 +244,19 @@ initDevice state sh device client = do
, btDevSigHandler = sh , btDevSigHandler = sh
} }
addDeviceListener :: MutableBtState -> IO () -> ObjectPath -> Client -> IO SignalHandler addDeviceListener :: MutableBtState -> IO () -> ObjectPath -> Client
addDeviceListener state display device = -> IO (Maybe SignalHandler)
addMatchCallback rule (procMatch . matchConnected) addDeviceListener state display device client = do
rule <- matchBTProperty client device
forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) client
where where
rule = matchProperty device
procMatch = withSignalMatch $ \c -> updateDevice state device c >> display procMatch = withSignalMatch $ \c -> updateDevice state device c >> display
matchConnected :: [Variant] -> SignalMatch Bool matchConnected :: [Variant] -> SignalMatch Bool
matchConnected = matchPropertyChanged devInterface devConnected matchConnected = matchPropertyChanged devInterface devConnected
callGetConnected :: ObjectPath -> Client -> IO [Variant] callGetConnected :: ObjectPath -> Client -> IO [Variant]
callGetConnected p = callPropertyGet btBus p devInterface devConnected callGetConnected p = callPropertyGet btBus p devInterface $ memberName_ devConnected
insertDevice :: MutableBtState -> ObjectPath -> BTDevice -> IO Bool insertDevice :: MutableBtState -> ObjectPath -> BTDevice -> IO Bool
insertDevice m device dev = modifyMVar m $ \s -> do insertDevice m device dev = modifyMVar m $ \s -> do

View File

@ -22,5 +22,5 @@ ckAlias = "clevokeyboard"
instance Exec ClevoKeyboard where instance Exec ClevoKeyboard where
alias (ClevoKeyboard _) = ckAlias alias (ClevoKeyboard _) = ckAlias
start (ClevoKeyboard icon) cb = do start (ClevoKeyboard icon) =
startBacklight matchSignalCK callGetBrightnessCK icon cb startBacklight matchSignalCK callGetBrightnessCK icon

View File

@ -7,6 +7,8 @@ module Xmobar.Plugins.Common
, fromSingletonVariant , fromSingletonVariant
, withDBusClientConnection , withDBusClientConnection
, Callback , Callback
, displayMaybe
, displayMaybe'
) )
where where
@ -16,8 +18,6 @@ import DBus
import DBus.Client import DBus.Client
import DBus.Internal import DBus.Internal
import Data.Maybe
import XMonad.Hooks.DynamicLog (xmobarColor) import XMonad.Hooks.DynamicLog (xmobarColor)
type Callback = String -> IO () type Callback = String -> IO ()
@ -27,15 +27,13 @@ startListener :: IsVariant a => MatchRule -> (Client -> IO [Variant])
-> Client -> IO () -> Client -> IO ()
startListener rule getProp fromSignal toColor cb client = do startListener rule getProp fromSignal toColor cb client = do
reply <- getProp client reply <- getProp client
procMatch $ maybe Failure Match $ fromVariant =<< listToMaybe reply displayMaybe cb toColor $ fromSingletonVariant reply
void $ addMatchCallback rule (procMatch . fromSignal) client void $ addMatchCallback rule (procMatch . fromSignal) client
where where
procMatch = procSignalMatch cb toColor procMatch = procSignalMatch cb toColor
procSignalMatch :: (String -> IO ()) -> (a -> IO String) -> SignalMatch a -> IO () procSignalMatch :: Callback -> (a -> IO String) -> SignalMatch a -> IO ()
procSignalMatch callback formatter (Match x) = callback =<< formatter x procSignalMatch cb f = withSignalMatch (displayMaybe cb f)
procSignalMatch callback _ Failure = callback na
procSignalMatch _ _ NoMatch = return ()
chooseColor :: String -> String -> String -> Bool -> String chooseColor :: String -> String -> String -> Bool -> String
chooseColor text colorOn colorOff state = chooseColor text colorOn colorOff state =
@ -44,8 +42,11 @@ chooseColor text colorOn colorOff state =
na :: String na :: String
na = "N/A" na = "N/A"
fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a displayMaybe :: Callback -> (a -> IO String) -> Maybe a -> IO ()
fromSingletonVariant = fromVariant <=< listToMaybe displayMaybe cb f = cb <=< maybe (return na) f
displayMaybe' :: Callback -> (a -> IO ()) -> Maybe a -> IO ()
displayMaybe' cb = maybe (cb na)
withDBusClientConnection :: Bool -> Callback -> (Client -> IO ()) -> IO () withDBusClientConnection :: Bool -> Callback -> (Client -> IO ()) -> IO ()
withDBusClientConnection sys cb f = maybe (cb na) f =<< getDBusClient sys withDBusClientConnection sys cb f = displayMaybe' cb f =<< getDBusClient sys

View File

@ -11,7 +11,6 @@ module Xmobar.Plugins.Device
import Control.Monad import Control.Monad
import Data.Maybe
import Data.Word import Data.Word
import DBus import DBus
@ -46,16 +45,15 @@ devDep :: DBusDep
devDep = Endpoint nmBus nmPath nmInterface $ Method_ getByIP devDep = Endpoint nmBus nmPath nmInterface $ Method_ getByIP
getDevice :: Client -> String -> IO (Maybe ObjectPath) getDevice :: Client -> String -> IO (Maybe ObjectPath)
getDevice client iface = either (const Nothing) (fromVariant <=< listToMaybe) getDevice client iface = bodyToMaybe <$> callMethod' client mc
<$> callMethod' client mc
where where
mc = (methodCall nmPath nmInterface getByIP) mc = (methodCallBus nmBus nmPath nmInterface getByIP)
{ methodCallBody = [toVariant iface] { methodCallBody = [toVariant iface]
, methodCallDestination = Just nmBus
} }
getDeviceConnected :: ObjectPath -> Client -> IO [Variant] getDeviceConnected :: ObjectPath -> Client -> IO [Variant]
getDeviceConnected path = callPropertyGet nmBus path nmDeviceInterface devSignal getDeviceConnected path = callPropertyGet nmBus path nmDeviceInterface
$ memberName_ devSignal
matchStatus :: [Variant] -> SignalMatch Word32 matchStatus :: [Variant] -> SignalMatch Word32
matchStatus = matchPropertyChanged nmDeviceInterface devSignal matchStatus = matchPropertyChanged nmDeviceInterface devSignal
@ -63,10 +61,13 @@ matchStatus = matchPropertyChanged nmDeviceInterface devSignal
instance Exec Device where instance Exec Device where
alias (Device (iface, _, _, _)) = iface alias (Device (iface, _, _, _)) = iface
start (Device (iface, text, colorOn, colorOff)) cb = do start (Device (iface, text, colorOn, colorOff)) cb = do
withDBusClientConnection True cb $ \c -> do withDBusClientConnection True cb $ \client -> do
path <- getDevice c iface path <- getDevice client iface
maybe (cb na) (listener c) path displayMaybe' cb (listener client) path
where where
listener client path = startListener (matchProperty path) listener client path = do
(getDeviceConnected path) matchStatus chooseColor' cb client rule <- matchPropertyFull client nmBus (Just path)
-- TODO warn the user here rather than silently drop the listener
forM_ rule $ \r ->
startListener r (getDeviceConnected path) matchStatus chooseColor' cb client
chooseColor' = return . chooseColor text colorOn colorOff . (> 1) chooseColor' = return . chooseColor text colorOn colorOff . (> 1)

View File

@ -22,5 +22,5 @@ blAlias = "intelbacklight"
instance Exec IntelBacklight where instance Exec IntelBacklight where
alias (IntelBacklight _) = blAlias alias (IntelBacklight _) = blAlias
start (IntelBacklight icon) cb = start (IntelBacklight icon) =
startBacklight matchSignalIB callGetBrightnessIB icon cb startBacklight matchSignalIB callGetBrightnessIB icon

View File

@ -23,8 +23,8 @@ instance Exec Screensaver where
alias (Screensaver _) = ssAlias alias (Screensaver _) = ssAlias
start (Screensaver (text, colorOn, colorOff)) cb = do start (Screensaver (text, colorOn, colorOff)) cb = do
withDBusClientConnection False cb $ \c -> do withDBusClientConnection False cb $ \c -> do
matchSignal (cb . fmtState) c matchSignal display c
cb . fmtState =<< callQuery c display =<< callQuery c
where where
fmtState = maybe na $ chooseColor text colorOn colorOff display = displayMaybe cb $ return . chooseColor text colorOn colorOff

View File

@ -9,6 +9,8 @@ module Xmobar.Plugins.VPN
, vpnDep , vpnDep
) where ) where
import Control.Monad
import DBus import DBus
import DBus.Internal import DBus.Internal
@ -39,10 +41,11 @@ vpnDep = Endpoint vpnBus vpnPath vpnInterface $ Property_ vpnConnType
instance Exec VPN where instance Exec VPN where
alias (VPN _) = vpnAlias alias (VPN _) = vpnAlias
start (VPN (text, colorOn, colorOff)) cb = start (VPN (text, colorOn, colorOff)) cb =
withDBusClientConnection True cb withDBusClientConnection True cb $ \c -> do
$ startListener rule getProp fromSignal chooseColor' cb rule <- matchPropertyFull c vpnBus (Just vpnPath)
-- TODO intelligently warn user
forM_ rule $ \r -> startListener r getProp fromSignal chooseColor' cb c
where where
rule = matchProperty vpnPath getProp = callPropertyGet vpnBus vpnPath vpnInterface $ memberName_ vpnConnType
getProp = callPropertyGet vpnBus vpnPath vpnInterface vpnConnType
fromSignal = matchPropertyChanged vpnInterface vpnConnType fromSignal = matchPropertyChanged vpnInterface vpnConnType
chooseColor' = return . chooseColor text colorOn colorOff . ("vpn" ==) chooseColor' = return . chooseColor text colorOn colorOff . ("vpn" ==)