diff --git a/lib/Xmobar/Plugins/Bluetooth.hs b/lib/Xmobar/Plugins/Bluetooth.hs index 23ad9f3..ef70c68 100644 --- a/lib/Xmobar/Plugins/Bluetooth.hs +++ b/lib/Xmobar/Plugins/Bluetooth.hs @@ -162,6 +162,9 @@ modifyState f = do m <- asks btState modifyMVar m f +beforeDisplay :: BTIO () -> BTIO () +beforeDisplay f = f >> join (asks btDisplay) + -------------------------------------------------------------------------------- -- Object manager @@ -211,8 +214,7 @@ addDeviceRemovedListener adapter sys = pathCallback :: ObjectPath -> (ObjectPath -> BTIO ()) -> SignalCallback BTIO pathCallback adapter f [device, _] = forM_ (fromVariant device) $ \d -> do - dpy <- asks btDisplay - when (adaptorHasDevice adapter d) $ f d >> dpy + when (adaptorHasDevice adapter d) $ beforeDisplay $ f d pathCallback _ _ _ = return () -------------------------------------------------------------------------------- @@ -261,10 +263,10 @@ withBTPropertyRule cl path update iface prop = do matchConnected = matchPropertyChanged iface prop addAdaptorListener :: ObjectPath -> SysClient -> BTIO (Maybe SignalHandler) -addAdaptorListener adaptor sys = do - dpy <- asks btDisplay - let procMatch b = putPowered b >> dpy +addAdaptorListener adaptor sys = withBTPropertyRule sys adaptor procMatch adapterInterface adaptorPowered + where + procMatch = beforeDisplay . putPowered callGetPowered :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) @@ -313,10 +315,10 @@ initDevice sh device sys = do } addDeviceListener :: ObjectPath -> SysClient -> BTIO (Maybe SignalHandler) -addDeviceListener device sys = do - dpy <- asks btDisplay - let procMatch c = updateDevice device c >> dpy +addDeviceListener device sys = withBTPropertyRule sys device procMatch devInterface devConnected + where + procMatch = beforeDisplay . void . updateDevice device callGetConnected :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) diff --git a/lib/Xmobar/Plugins/VPN.hs b/lib/Xmobar/Plugins/VPN.hs index 9cc3f5a..b7b52df 100644 --- a/lib/Xmobar/Plugins/VPN.hs +++ b/lib/Xmobar/Plugins/VPN.hs @@ -33,11 +33,11 @@ instance Exec VPN where start (VPN (text, colors)) cb = withDBusClientConnection cb "VPN" $ \c -> do state <- initState c - let dpy = displayMaybe cb iconFormatter . Just =<< readState state - let signalCallback' f = f state dpy - vpnAddedListener (signalCallback' addedCallback) c - vpnRemovedListener (signalCallback' removedCallback) c - dpy + let dpy = displayMaybe cb iconFormatter . Just =<< readState + mapRIO (VEnv state dpy) $ do + vpnAddedListener addedCallback c + vpnRemovedListener removedCallback c + dpy where iconFormatter b = return $ colorText colors b text @@ -48,6 +48,17 @@ instance Exec VPN where -- this will be a null or singleton set, but this setup could handle the edge -- case of multiple VPNs being active at once without puking. +data VEnv = VEnv + { vState :: !MutableVPNState + , vDisplay :: !(VIO ()) + , vEnv :: !SimpleApp + } + +instance HasLogFunc VEnv where + logFuncL = lens vEnv (\x y -> x {vEnv = y}) . logFuncL + +type VIO = RIO VEnv + type VPNState = S.Set ObjectPath type MutableVPNState = MVar VPNState @@ -60,16 +71,16 @@ initState client = do ot <- getVPNObjectTree client newMVar $ findTunnels ot -readState :: MonadUnliftIO m => MutableVPNState -> m Bool -readState = fmap (not . null) . readMVar +readState :: VIO Bool +readState = fmap (not . null) . readMVar =<< asks vState -updateState - :: MonadUnliftIO m - => (ObjectPath -> VPNState -> VPNState) - -> MutableVPNState - -> ObjectPath - -> m () -updateState f state op = modifyMVar_ state $ return . f op +updateState :: (ObjectPath -> VPNState -> VPNState) -> ObjectPath -> VIO () +updateState f op = do + s <- asks vState + modifyMVar_ s $ return . f op + +beforeDisplay :: VIO () -> VIO () +beforeDisplay f = f >> join (asks vDisplay) -------------------------------------------------------------------------------- -- Tunnel Device Detection @@ -97,32 +108,33 @@ vpnRemovedListener -> m () vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb -addedCallback :: MonadUnliftIO m => MutableVPNState -> m () -> SignalCallback m -addedCallback state dpy [device, added] = update >> dpy +addedCallback :: SignalCallback VIO +addedCallback [device, added] = + beforeDisplay $ + updateDevice S.insert device $ + M.keys $ + fromMaybe M.empty added' 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 () +addedCallback _ = return () -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 () +removedCallback :: SignalCallback VIO +removedCallback [device, interfaces] = + beforeDisplay $ + updateDevice S.delete device $ + fromMaybe [] $ + fromVariant interfaces +removedCallback _ = return () updateDevice - :: MonadUnliftIO m - => (ObjectPath -> VPNState -> VPNState) - -> MutableVPNState + :: (ObjectPath -> VPNState -> VPNState) -> Variant -> [T.Text] - -> m () -updateDevice f state device interfaces = + -> VIO () +updateDevice f device interfaces = when (vpnDeviceTun `elem` interfaces) $ forM_ d $ - updateState f state + updateState f where d = fromVariant device :: Maybe ObjectPath