ENH use busname when matching signal
This commit is contained in:
parent
b9ede93e98
commit
9e4589cc98
|
|
@ -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
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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 =
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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" ==)
|
||||
|
|
|
|||
Loading…
Reference in New Issue