ENH generalize signal callbacks
This commit is contained in:
parent
993b9e731a
commit
4aae54b90e
|
|
@ -137,15 +137,16 @@ bodyToMaybe = either (const Nothing) fromSingletonVariant
|
|||
--------------------------------------------------------------------------------
|
||||
-- Signals
|
||||
|
||||
type SignalCallback = [Variant] -> IO ()
|
||||
type SignalCallback m = [Variant] -> m ()
|
||||
|
||||
addMatchCallback
|
||||
:: (MonadUnliftIO m, SafeClient c)
|
||||
=> MatchRule
|
||||
-> SignalCallback
|
||||
-> SignalCallback m
|
||||
-> c
|
||||
-> m SignalHandler
|
||||
addMatchCallback rule cb cl = liftIO . addMatch (toClient cl) rule $ cb . signalBody
|
||||
addMatchCallback rule cb cl = withRunInIO $ \run -> do
|
||||
addMatch (toClient cl) rule $ run . cb . signalBody
|
||||
|
||||
matchSignal
|
||||
:: Maybe BusName
|
||||
|
|
@ -266,7 +267,7 @@ addInterfaceChangedListener
|
|||
=> BusName
|
||||
-> MemberName
|
||||
-> ObjectPath
|
||||
-> SignalCallback
|
||||
-> SignalCallback m
|
||||
-> c
|
||||
-> m (Maybe SignalHandler)
|
||||
addInterfaceChangedListener bus prop path sc cl = do
|
||||
|
|
@ -277,7 +278,7 @@ addInterfaceAddedListener
|
|||
:: (MonadUnliftIO m, SafeClient c)
|
||||
=> BusName
|
||||
-> ObjectPath
|
||||
-> SignalCallback
|
||||
-> SignalCallback m
|
||||
-> c
|
||||
-> m (Maybe SignalHandler)
|
||||
addInterfaceAddedListener bus =
|
||||
|
|
@ -287,7 +288,7 @@ addInterfaceRemovedListener
|
|||
:: (MonadUnliftIO m, SafeClient c)
|
||||
=> BusName
|
||||
-> ObjectPath
|
||||
-> SignalCallback
|
||||
-> SignalCallback m
|
||||
-> c
|
||||
-> m (Maybe SignalHandler)
|
||||
addInterfaceRemovedListener bus =
|
||||
|
|
|
|||
|
|
@ -39,7 +39,6 @@ module Xmobar.Plugins.Bluetooth
|
|||
)
|
||||
where
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Monad
|
||||
import DBus
|
||||
import DBus.Client
|
||||
|
|
@ -49,6 +48,7 @@ import Data.List
|
|||
import Data.List.Split
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe
|
||||
import RIO
|
||||
import qualified RIO.Text as T
|
||||
import XMonad.Internal.DBus.Common
|
||||
import Xmobar
|
||||
|
|
@ -73,19 +73,19 @@ startAdapter :: Icons -> Colors -> Callback -> SysClient -> IO ()
|
|||
startAdapter is cs cb cl = do
|
||||
ot <- getBtObjectTree cl
|
||||
state <- newMVar emptyState
|
||||
let display = displayIcon cb (iconFormatter is cs) state
|
||||
let dpy = displayIcon cb (iconFormatter is cs) state
|
||||
forM_ (findAdapter ot) $ \adapter -> do
|
||||
-- set up adapter
|
||||
initAdapter state adapter cl
|
||||
-- TODO this step could fail; at least warn the user...
|
||||
void $ addAdaptorListener state display adapter cl
|
||||
void $ addAdaptorListener state dpy adapter cl
|
||||
-- set up devices on the adapter (and listeners for adding/removing devices)
|
||||
let devices = findDevices adapter ot
|
||||
addDeviceAddedListener state display adapter cl
|
||||
addDeviceRemovedListener state display adapter cl
|
||||
forM_ devices $ \d -> addAndInitDevice state display d cl
|
||||
addDeviceAddedListener state dpy adapter cl
|
||||
addDeviceRemovedListener state dpy adapter cl
|
||||
forM_ devices $ \d -> addAndInitDevice state dpy d cl
|
||||
-- after setting things up, show the icon based on the initialized state
|
||||
display
|
||||
dpy
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Icon Display
|
||||
|
|
@ -166,27 +166,27 @@ getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath
|
|||
btOMPath :: ObjectPath
|
||||
btOMPath = objectPath_ "/"
|
||||
|
||||
addBtOMListener :: SignalCallback -> SysClient -> IO ()
|
||||
addBtOMListener :: MonadUnliftIO m => SignalCallback m -> SysClient -> m ()
|
||||
addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc
|
||||
|
||||
addDeviceAddedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
|
||||
addDeviceAddedListener state display adapter client =
|
||||
addDeviceAddedListener state dpy adapter client =
|
||||
addBtOMListener addDevice client
|
||||
where
|
||||
addDevice = pathCallback adapter display $ \d ->
|
||||
addAndInitDevice state display d client
|
||||
addDevice = pathCallback adapter dpy $ \d ->
|
||||
addAndInitDevice state dpy d client
|
||||
|
||||
addDeviceRemovedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
|
||||
addDeviceRemovedListener state display adapter sys =
|
||||
addDeviceRemovedListener state dpy adapter sys =
|
||||
addBtOMListener remDevice sys
|
||||
where
|
||||
remDevice = pathCallback adapter display $ \d -> do
|
||||
remDevice = pathCallback adapter dpy $ \d -> do
|
||||
old <- removeDevice state d
|
||||
forM_ old $ removeMatch (toClient sys) . btDevSigHandler
|
||||
|
||||
pathCallback :: ObjectPath -> IO () -> (ObjectPath -> IO ()) -> SignalCallback
|
||||
pathCallback adapter display f [device, _] = forM_ (fromVariant device) $ \d ->
|
||||
when (adaptorHasDevice adapter d) $ f d >> display
|
||||
pathCallback :: MonadUnliftIO m => ObjectPath -> IO () -> (ObjectPath -> IO ()) -> SignalCallback m
|
||||
pathCallback adapter dpy f [device, _] = liftIO $ forM_ (fromVariant device) $ \d ->
|
||||
when (adaptorHasDevice adapter d) $ f d >> dpy
|
||||
pathCallback _ _ _ _ = return ()
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -206,11 +206,11 @@ addAdaptorListener
|
|||
-> ObjectPath
|
||||
-> SysClient
|
||||
-> IO (Maybe SignalHandler)
|
||||
addAdaptorListener state display adaptor sys = do
|
||||
addAdaptorListener state dpy adaptor sys = do
|
||||
rule <- matchBTProperty sys adaptor
|
||||
forM rule $ \r -> addMatchCallback r (procMatch . matchPowered) sys
|
||||
where
|
||||
procMatch = withSignalMatch $ \b -> putPowered state b >> display
|
||||
procMatch = withSignalMatch $ \b -> putPowered state b >> dpy
|
||||
|
||||
callGetPowered :: ObjectPath -> SysClient -> IO [Variant]
|
||||
callGetPowered adapter =
|
||||
|
|
@ -237,8 +237,8 @@ adaptorPowered = "Powered"
|
|||
-- Devices
|
||||
|
||||
addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
|
||||
addAndInitDevice state display device client = do
|
||||
sh <- addDeviceListener state display device client
|
||||
addAndInitDevice state dpy device client = do
|
||||
sh <- addDeviceListener state dpy device client
|
||||
-- TODO add some intelligent error messages here
|
||||
forM_ sh $ \s -> initDevice state s device client
|
||||
|
||||
|
|
@ -258,11 +258,11 @@ addDeviceListener
|
|||
-> ObjectPath
|
||||
-> SysClient
|
||||
-> IO (Maybe SignalHandler)
|
||||
addDeviceListener state display device sys = do
|
||||
addDeviceListener state dpy device sys = do
|
||||
rule <- matchBTProperty sys device
|
||||
forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) sys
|
||||
where
|
||||
procMatch = withSignalMatch $ \c -> updateDevice state device c >> display
|
||||
procMatch = withSignalMatch $ \c -> updateDevice state device c >> dpy
|
||||
|
||||
matchConnected :: [Variant] -> SignalMatch Bool
|
||||
matchConnected = matchPropertyChanged devInterface devConnected
|
||||
|
|
|
|||
|
|
@ -14,14 +14,13 @@ module Xmobar.Plugins.VPN
|
|||
)
|
||||
where
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Monad
|
||||
import DBus
|
||||
import Data.Internal.DBus
|
||||
import Data.Internal.Dependency
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe
|
||||
import qualified Data.Set as S
|
||||
import RIO
|
||||
import qualified RIO.Text as T
|
||||
import XMonad.Internal.Command.Desktop
|
||||
import XMonad.Internal.DBus.Common
|
||||
|
|
@ -35,11 +34,11 @@ instance Exec VPN where
|
|||
start (VPN (text, colors)) cb =
|
||||
withDBusClientConnection cb $ \c -> do
|
||||
state <- initState c
|
||||
let display = displayMaybe cb iconFormatter . Just =<< readState state
|
||||
let signalCallback' f = f state display
|
||||
let dpy = displayMaybe cb iconFormatter . Just =<< readState state
|
||||
let signalCallback' f = f state dpy
|
||||
vpnAddedListener (signalCallback' addedCallback) c
|
||||
vpnRemovedListener (signalCallback' removedCallback) c
|
||||
display
|
||||
dpy
|
||||
where
|
||||
iconFormatter b = return $ colorText colors b text
|
||||
|
||||
|
|
@ -63,10 +62,11 @@ readState :: MutableVPNState -> IO Bool
|
|||
readState = fmap (not . null) . readMVar
|
||||
|
||||
updateState
|
||||
:: (ObjectPath -> VPNState -> VPNState)
|
||||
:: MonadUnliftIO m
|
||||
=> (ObjectPath -> VPNState -> VPNState)
|
||||
-> MutableVPNState
|
||||
-> ObjectPath
|
||||
-> IO ()
|
||||
-> m ()
|
||||
updateState f state op = modifyMVar_ state $ return . f op
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -78,33 +78,34 @@ getVPNObjectTree sys = callGetManagedObjects sys vpnBus vpnPath
|
|||
findTunnels :: ObjectTree -> VPNState
|
||||
findTunnels = S.fromList . M.keys . M.filter (elem vpnDeviceTun . M.keys)
|
||||
|
||||
vpnAddedListener :: SignalCallback -> SysClient -> IO ()
|
||||
vpnAddedListener :: MonadUnliftIO m => SignalCallback m -> SysClient -> m ()
|
||||
vpnAddedListener cb = void . addInterfaceAddedListener vpnBus vpnPath cb
|
||||
|
||||
vpnRemovedListener :: SignalCallback -> SysClient -> IO ()
|
||||
vpnRemovedListener :: MonadUnliftIO m => SignalCallback m -> SysClient -> m ()
|
||||
vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb
|
||||
|
||||
addedCallback :: MutableVPNState -> IO () -> SignalCallback
|
||||
addedCallback state display [device, added] = update >> display
|
||||
addedCallback :: MonadUnliftIO m => MutableVPNState -> m () -> SignalCallback m
|
||||
addedCallback state dpy [device, added] = update >> dpy
|
||||
where
|
||||
added' = fromVariant added :: Maybe (M.Map T.Text (M.Map T.Text Variant))
|
||||
is = M.keys $ fromMaybe M.empty added'
|
||||
update = updateDevice S.insert state device is
|
||||
addedCallback _ _ _ = return ()
|
||||
|
||||
removedCallback :: MutableVPNState -> IO () -> SignalCallback
|
||||
removedCallback state display [device, interfaces] = update >> display
|
||||
removedCallback :: MonadUnliftIO m => MutableVPNState -> m () -> SignalCallback m
|
||||
removedCallback state dpy [device, interfaces] = update >> dpy
|
||||
where
|
||||
is = fromMaybe [] $ fromVariant interfaces :: [T.Text]
|
||||
update = updateDevice S.delete state device is
|
||||
removedCallback _ _ _ = return ()
|
||||
|
||||
updateDevice
|
||||
:: (ObjectPath -> VPNState -> VPNState)
|
||||
:: MonadUnliftIO m
|
||||
=> (ObjectPath -> VPNState -> VPNState)
|
||||
-> MutableVPNState
|
||||
-> Variant
|
||||
-> [T.Text]
|
||||
-> IO ()
|
||||
-> m ()
|
||||
updateDevice f state device interfaces =
|
||||
when (vpnDeviceTun `elem` interfaces) $
|
||||
forM_ d $
|
||||
|
|
|
|||
Loading…
Reference in New Issue