From 9e4589cc982b834d777e7ee63600b10c081067f0 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sat, 27 Nov 2021 13:24:13 -0500 Subject: [PATCH] ENH use busname when matching signal --- lib/DBus/Internal.hs | 130 +++++++++++------- lib/XMonad/Internal/DBus/Brightness/Common.hs | 11 +- lib/Xmobar/Plugins/BacklightCommon.hs | 10 +- lib/Xmobar/Plugins/Bluetooth.hs | 46 ++++--- lib/Xmobar/Plugins/ClevoKeyboard.hs | 4 +- lib/Xmobar/Plugins/Common.hs | 21 +-- lib/Xmobar/Plugins/Device.hs | 23 ++-- lib/Xmobar/Plugins/IntelBacklight.hs | 4 +- lib/Xmobar/Plugins/Screensaver.hs | 6 +- lib/Xmobar/Plugins/VPN.hs | 11 +- 10 files changed, 158 insertions(+), 108 deletions(-) diff --git a/lib/DBus/Internal.hs b/lib/DBus/Internal.hs index 9f033be..541b729 100644 --- a/lib/DBus/Internal.hs +++ b/lib/DBus/Internal.hs @@ -4,10 +4,11 @@ module DBus.Internal ( addMatchCallback , getDBusClient + , fromDBusClient , withDBusClient , withDBusClient_ , matchProperty - , matchProperty' + , matchPropertyFull , matchPropertyChanged , SignalMatch(..) , SignalCallback @@ -16,12 +17,15 @@ module DBus.Internal , callPropertyGet , callMethod , callMethod' + , methodCallBus , callGetManagedObjects , ObjectTree , getManagedObjects , omInterface , addInterfaceAddedListener , addInterfaceRemovedListener + , fromSingletonVariant + , bodyToMaybe ) where import Control.Exception @@ -44,9 +48,33 @@ callMethod' cl = fmap (bimap methodErrorMessage methodReturnBody) . call cl callMethod :: Client -> BusName -> ObjectPath -> InterfaceName -> MemberName -> IO MethodBody -callMethod client bus path iface mem = - callMethod' client (methodCall path iface mem) - { methodCallDestination = Just bus } +callMethod client bus path iface = callMethod' client . methodCallBus bus path iface + +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 @@ -56,6 +84,20 @@ type SignalCallback = [Variant] -> IO () addMatchCallback :: MatchRule -> SignalCallback -> Client -> IO SignalHandler 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 @@ -65,26 +107,18 @@ propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties" propertySignal :: MemberName propertySignal = memberName_ "PropertiesChanged" -callPropertyGet :: BusName -> ObjectPath -> InterfaceName -> String -> Client +callPropertyGet :: BusName -> ObjectPath -> InterfaceName -> MemberName -> Client -> IO [Variant] -callPropertyGet bus path iface property client = either (const []) (:[]) - <$> getProperty client (methodCall path iface $ memberName_ property) - { methodCallDestination = Just bus } +callPropertyGet bus path iface property client = fmap (either (const []) (:[])) + $ getProperty client $ methodCallBus bus path iface property --- TODO actually get the real busname when using this (will involve IO) -matchProperty' :: Maybe 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 = p - , matchInterface = Just propertyInterface - , matchMember = Just propertySignal - } +matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule +matchProperty b p = + matchSignal b p (Just propertyInterface) (Just propertySignal) -matchProperty :: ObjectPath -> MatchRule -matchProperty = matchProperty' . Just +matchPropertyFull :: Client -> BusName -> Maybe ObjectPath -> IO (Maybe MatchRule) +matchPropertyFull client b p = + matchSignalFull client b p (Just propertyInterface) (Just propertySignal) data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show) @@ -117,18 +151,19 @@ getDBusClient sys = do Left e -> putStrLn (clientErrorMessage e) >> return Nothing Right c -> return $ Just c -withDBusClient :: Bool -> (Client -> a) -> IO (Maybe a) +withDBusClient :: Bool -> (Client -> IO a) -> IO (Maybe a) withDBusClient sys f = do client <- getDBusClient sys - let r = f <$> client - mapM_ disconnect client - return r + forM client $ \c -> do + r <- f c + disconnect c + return r withDBusClient_ :: Bool -> (Client -> IO ()) -> IO () -withDBusClient_ sys f = do - client <- getDBusClient sys - mapM_ f client - mapM_ disconnect client +withDBusClient_ sys = void . withDBusClient sys + +fromDBusClient :: Bool -> (Client -> a) -> IO (Maybe a) +fromDBusClient sys f = withDBusClient sys (return . f) -------------------------------------------------------------------------------- -- | Object Manager @@ -141,30 +176,29 @@ omInterface = interfaceName_ "org.freedesktop.DBus.ObjectManager" getManagedObjects :: MemberName 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_ "InterfacesAdded" omInterfacesRemoved :: MemberName omInterfacesRemoved = memberName_ "InterfacesRemoved" --- TODO add busname back to this (use NameGetOwner on org.freedesktop.DBus) -addInterfaceChangedListener :: MemberName -> ObjectPath -> SignalCallback - -> Client -> IO () -addInterfaceChangedListener prop path = fmap void . addMatchCallback rule - where - rule = matchAny - { matchPath = Just path - , matchInterface = Just omInterface - , matchMember = Just prop - } +callGetManagedObjects :: Client -> BusName -> ObjectPath -> IO ObjectTree +callGetManagedObjects client bus path = + either (const M.empty) (fromMaybe M.empty . fromSingletonVariant) + <$> callMethod client bus path omInterface getManagedObjects -addInterfaceAddedListener :: ObjectPath -> SignalCallback -> Client -> IO () -addInterfaceAddedListener = addInterfaceChangedListener omInterfacesAdded +addInterfaceChangedListener :: BusName -> MemberName -> ObjectPath + -> 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 () -addInterfaceRemovedListener = addInterfaceChangedListener omInterfacesRemoved +addInterfaceAddedListener :: BusName -> ObjectPath -> SignalCallback -> Client + -> IO (Maybe SignalHandler) +addInterfaceAddedListener bus = + addInterfaceChangedListener bus omInterfacesAdded + +addInterfaceRemovedListener :: BusName -> ObjectPath -> SignalCallback -> Client + -> IO (Maybe SignalHandler) +addInterfaceRemovedListener bus = + addInterfaceChangedListener bus omInterfacesRemoved diff --git a/lib/XMonad/Internal/DBus/Brightness/Common.hs b/lib/XMonad/Internal/DBus/Brightness/Common.hs index 04e133e..93f046a 100644 --- a/lib/XMonad/Internal/DBus/Brightness/Common.hs +++ b/lib/XMonad/Internal/DBus/Brightness/Common.hs @@ -62,11 +62,10 @@ brightnessControls bc client = where cb = callBacklight client bc --- TODO not dry callGetBrightness :: Num c => BrightnessConfig a b -> Client -> IO (Maybe c) -callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client = do - reply <- callMethod client xmonadBusName p i memGet - return $ either (const Nothing) bodyGetBrightness reply +callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client = + either (const Nothing) bodyGetBrightness + <$> callMethod client xmonadBusName p i memGet signalDep :: BrightnessConfig a b -> DBusDep 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 = void . addMatchCallback brMatcher (cb . bodyGetBrightness) where + -- TODO add busname to this brMatcher = matchAny { matchPath = Just p , matchInterface = Just i @@ -128,7 +128,8 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur = where 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 , bcInterface = i , bcName = n } controlName m = diff --git a/lib/Xmobar/Plugins/BacklightCommon.hs b/lib/Xmobar/Plugins/BacklightCommon.hs index 822eda5..25e3168 100644 --- a/lib/Xmobar/Plugins/BacklightCommon.hs +++ b/lib/Xmobar/Plugins/BacklightCommon.hs @@ -11,11 +11,11 @@ import DBus.Client import Xmobar.Plugins.Common 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 withDBusClientConnection False cb $ \c -> do - matchSignal (cb . formatBrightness) c - cb . formatBrightness =<< callGetBrightness c + matchSignal display c + display =<< callGetBrightness c where - formatBrightness = maybe na $ - \b -> icon ++ show (round b :: Integer) ++ "%" + formatBrightness b = return $ icon ++ show (round b :: Integer) ++ "%" + display = displayMaybe cb formatBrightness diff --git a/lib/Xmobar/Plugins/Bluetooth.hs b/lib/Xmobar/Plugins/Bluetooth.hs index 0ceec98..34b6de1 100644 --- a/lib/Xmobar/Plugins/Bluetooth.hs +++ b/lib/Xmobar/Plugins/Bluetooth.hs @@ -56,7 +56,7 @@ btAlias :: String btAlias = "bluetooth" btDep :: DBusDep -btDep = Endpoint btBus btOmPath omInterface $ Method_ getManagedObjects +btDep = Endpoint btBus btOMPath omInterface $ Method_ getManagedObjects data Bluetooth = Bluetooth Icons Colors deriving (Read, Show) @@ -73,7 +73,8 @@ startAdapter is cs cb cl = do forM_ (findAdapter ot) $ \adapter -> do -- set up adapter 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) let devices = findDevices adapter ot addDeviceAddedListener state display adapter cl @@ -157,24 +158,27 @@ splitPath :: ObjectPath -> [String] splitPath = splitOn "/" . dropWhile (=='/') . formatObjectPath getBtObjectTree :: Client -> IO ObjectTree -getBtObjectTree client = callGetManagedObjects client btBus btOmPath +getBtObjectTree client = callGetManagedObjects client btBus btOMPath btBus :: BusName 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 state display adapter client = - addInterfaceAddedListener btOmPath addDevice client + addBtOMListener addDevice client where addDevice = pathCallback adapter display $ \d -> addAndInitDevice state display d client addDeviceRemovedListener :: MutableBtState -> IO () -> ObjectPath -> Client -> IO () addDeviceRemovedListener state display adapter client = - addInterfaceRemovedListener btOmPath remDevice client + addBtOMListener remDevice client where remDevice = pathCallback adapter display $ \d -> do old <- removeDevice state d @@ -193,16 +197,20 @@ initAdapter state adapter client = do reply <- callGetPowered adapter client putPowered state $ fromSingletonVariant reply -addAdaptorListener :: MutableBtState -> IO () -> ObjectPath -> Client -> IO () -addAdaptorListener state display adaptor = - void . addMatchCallback rule (procMatch . matchPowered) +matchBTProperty :: Client -> ObjectPath -> IO (Maybe MatchRule) +matchBTProperty client p = matchPropertyFull client btBus (Just p) + +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 - rule = matchProperty adaptor procMatch = withSignalMatch $ \b -> putPowered state b >> display callGetPowered :: ObjectPath -> Client -> IO [Variant] callGetPowered adapter = - callPropertyGet btBus adapter adapterInterface adaptorPowered + callPropertyGet btBus adapter adapterInterface $ memberName_ adaptorPowered matchPowered :: [Variant] -> SignalMatch Bool matchPowered = matchPropertyChanged adapterInterface adaptorPowered @@ -225,7 +233,8 @@ adaptorPowered = "Powered" addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> Client -> IO () addAndInitDevice state display device client = do 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 state sh device client = do @@ -235,18 +244,19 @@ initDevice state sh device client = do , btDevSigHandler = sh } -addDeviceListener :: MutableBtState -> IO () -> ObjectPath -> Client -> IO SignalHandler -addDeviceListener state display device = - addMatchCallback rule (procMatch . matchConnected) +addDeviceListener :: MutableBtState -> IO () -> ObjectPath -> Client + -> IO (Maybe SignalHandler) +addDeviceListener state display device client = do + rule <- matchBTProperty client device + forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) client where - rule = matchProperty device procMatch = withSignalMatch $ \c -> updateDevice state device c >> display matchConnected :: [Variant] -> SignalMatch Bool matchConnected = matchPropertyChanged devInterface devConnected 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 m device dev = modifyMVar m $ \s -> do diff --git a/lib/Xmobar/Plugins/ClevoKeyboard.hs b/lib/Xmobar/Plugins/ClevoKeyboard.hs index 2cdc1c5..58d3123 100644 --- a/lib/Xmobar/Plugins/ClevoKeyboard.hs +++ b/lib/Xmobar/Plugins/ClevoKeyboard.hs @@ -22,5 +22,5 @@ ckAlias = "clevokeyboard" instance Exec ClevoKeyboard where alias (ClevoKeyboard _) = ckAlias - start (ClevoKeyboard icon) cb = do - startBacklight matchSignalCK callGetBrightnessCK icon cb + start (ClevoKeyboard icon) = + startBacklight matchSignalCK callGetBrightnessCK icon diff --git a/lib/Xmobar/Plugins/Common.hs b/lib/Xmobar/Plugins/Common.hs index 24acaa5..5b09185 100644 --- a/lib/Xmobar/Plugins/Common.hs +++ b/lib/Xmobar/Plugins/Common.hs @@ -7,6 +7,8 @@ module Xmobar.Plugins.Common , fromSingletonVariant , withDBusClientConnection , Callback + , displayMaybe + , displayMaybe' ) where @@ -16,8 +18,6 @@ import DBus import DBus.Client import DBus.Internal -import Data.Maybe - import XMonad.Hooks.DynamicLog (xmobarColor) type Callback = String -> IO () @@ -27,15 +27,13 @@ startListener :: IsVariant a => MatchRule -> (Client -> IO [Variant]) -> Client -> IO () startListener rule getProp fromSignal toColor cb client = do reply <- getProp client - procMatch $ maybe Failure Match $ fromVariant =<< listToMaybe reply + displayMaybe cb toColor $ fromSingletonVariant reply void $ addMatchCallback rule (procMatch . fromSignal) client where procMatch = procSignalMatch cb toColor -procSignalMatch :: (String -> IO ()) -> (a -> IO String) -> SignalMatch a -> IO () -procSignalMatch callback formatter (Match x) = callback =<< formatter x -procSignalMatch callback _ Failure = callback na -procSignalMatch _ _ NoMatch = return () +procSignalMatch :: Callback -> (a -> IO String) -> SignalMatch a -> IO () +procSignalMatch cb f = withSignalMatch (displayMaybe cb f) chooseColor :: String -> String -> String -> Bool -> String chooseColor text colorOn colorOff state = @@ -44,8 +42,11 @@ chooseColor text colorOn colorOff state = na :: String na = "N/A" -fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a -fromSingletonVariant = fromVariant <=< listToMaybe +displayMaybe :: Callback -> (a -> IO String) -> Maybe a -> IO () +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 sys cb f = maybe (cb na) f =<< getDBusClient sys +withDBusClientConnection sys cb f = displayMaybe' cb f =<< getDBusClient sys diff --git a/lib/Xmobar/Plugins/Device.hs b/lib/Xmobar/Plugins/Device.hs index 1beaf74..f186056 100644 --- a/lib/Xmobar/Plugins/Device.hs +++ b/lib/Xmobar/Plugins/Device.hs @@ -11,7 +11,6 @@ module Xmobar.Plugins.Device import Control.Monad -import Data.Maybe import Data.Word import DBus @@ -46,16 +45,15 @@ devDep :: DBusDep devDep = Endpoint nmBus nmPath nmInterface $ Method_ getByIP getDevice :: Client -> String -> IO (Maybe ObjectPath) -getDevice client iface = either (const Nothing) (fromVariant <=< listToMaybe) - <$> callMethod' client mc +getDevice client iface = bodyToMaybe <$> callMethod' client mc where - mc = (methodCall nmPath nmInterface getByIP) + mc = (methodCallBus nmBus nmPath nmInterface getByIP) { methodCallBody = [toVariant iface] - , methodCallDestination = Just nmBus } 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 = matchPropertyChanged nmDeviceInterface devSignal @@ -63,10 +61,13 @@ matchStatus = matchPropertyChanged nmDeviceInterface devSignal instance Exec Device where alias (Device (iface, _, _, _)) = iface start (Device (iface, text, colorOn, colorOff)) cb = do - withDBusClientConnection True cb $ \c -> do - path <- getDevice c iface - maybe (cb na) (listener c) path + withDBusClientConnection True cb $ \client -> do + path <- getDevice client iface + displayMaybe' cb (listener client) path where - listener client path = startListener (matchProperty path) - (getDeviceConnected path) matchStatus chooseColor' cb client + listener client path = do + 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) diff --git a/lib/Xmobar/Plugins/IntelBacklight.hs b/lib/Xmobar/Plugins/IntelBacklight.hs index 7c4efb3..48814c9 100644 --- a/lib/Xmobar/Plugins/IntelBacklight.hs +++ b/lib/Xmobar/Plugins/IntelBacklight.hs @@ -22,5 +22,5 @@ blAlias = "intelbacklight" instance Exec IntelBacklight where alias (IntelBacklight _) = blAlias - start (IntelBacklight icon) cb = - startBacklight matchSignalIB callGetBrightnessIB icon cb + start (IntelBacklight icon) = + startBacklight matchSignalIB callGetBrightnessIB icon diff --git a/lib/Xmobar/Plugins/Screensaver.hs b/lib/Xmobar/Plugins/Screensaver.hs index d1791f8..6ac0738 100644 --- a/lib/Xmobar/Plugins/Screensaver.hs +++ b/lib/Xmobar/Plugins/Screensaver.hs @@ -23,8 +23,8 @@ instance Exec Screensaver where alias (Screensaver _) = ssAlias start (Screensaver (text, colorOn, colorOff)) cb = do withDBusClientConnection False cb $ \c -> do - matchSignal (cb . fmtState) c - cb . fmtState =<< callQuery c + matchSignal display c + display =<< callQuery c where - fmtState = maybe na $ chooseColor text colorOn colorOff + display = displayMaybe cb $ return . chooseColor text colorOn colorOff diff --git a/lib/Xmobar/Plugins/VPN.hs b/lib/Xmobar/Plugins/VPN.hs index 7b2890e..1c6f2af 100644 --- a/lib/Xmobar/Plugins/VPN.hs +++ b/lib/Xmobar/Plugins/VPN.hs @@ -9,6 +9,8 @@ module Xmobar.Plugins.VPN , vpnDep ) where +import Control.Monad + import DBus import DBus.Internal @@ -39,10 +41,11 @@ vpnDep = Endpoint vpnBus vpnPath vpnInterface $ Property_ vpnConnType instance Exec VPN where alias (VPN _) = vpnAlias start (VPN (text, colorOn, colorOff)) cb = - withDBusClientConnection True cb - $ startListener rule getProp fromSignal chooseColor' cb + withDBusClientConnection True cb $ \c -> do + rule <- matchPropertyFull c vpnBus (Just vpnPath) + -- TODO intelligently warn user + forM_ rule $ \r -> startListener r getProp fromSignal chooseColor' cb c where - rule = matchProperty vpnPath - getProp = callPropertyGet vpnBus vpnPath vpnInterface vpnConnType + getProp = callPropertyGet vpnBus vpnPath vpnInterface $ memberName_ vpnConnType fromSignal = matchPropertyChanged vpnInterface vpnConnType chooseColor' = return . chooseColor text colorOn colorOff . ("vpn" ==)