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