From a0cdcce146abcbfcff3203c01d9e4b884c1916e0 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Tue, 3 Jan 2023 22:18:55 -0500 Subject: [PATCH] ENH hold client in monad --- lib/Data/Internal/DBus.hs | 160 +++++++++++++----- lib/Data/Internal/XIO.hs | 23 ++- .../Internal/DBus/Brightness/ClevoKeyboard.hs | 18 +- lib/XMonad/Internal/DBus/Brightness/Common.hs | 48 +++--- .../DBus/Brightness/IntelBacklight.hs | 18 +- lib/XMonad/Internal/DBus/Removable.hs | 23 ++- lib/XMonad/Internal/DBus/Screensaver.hs | 26 ++- lib/Xmobar/Plugins/BacklightCommon.hs | 10 +- lib/Xmobar/Plugins/Bluetooth.hs | 140 +++++++++------ lib/Xmobar/Plugins/Common.hs | 17 +- lib/Xmobar/Plugins/Device.hs | 28 +-- lib/Xmobar/Plugins/Screensaver.hs | 7 +- lib/Xmobar/Plugins/VPN.hs | 66 +++++--- 13 files changed, 385 insertions(+), 199 deletions(-) diff --git a/lib/Data/Internal/DBus.hs b/lib/Data/Internal/DBus.hs index 69651a1..18cc40e 100644 --- a/lib/Data/Internal/DBus.hs +++ b/lib/Data/Internal/DBus.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- @@ -7,6 +9,10 @@ module Data.Internal.DBus ( SafeClient (..) , SysClient (..) , SesClient (..) + , DBusEnv (..) + , DIO + , HasClient (..) + , withDIO , addMatchCallback , matchProperty , matchPropertyFull @@ -102,26 +108,49 @@ getDBusClient' sys = do return Nothing Right c -> return $ Just c +data DBusEnv env c = DBusEnv {dClient :: !c, dEnv :: !env} + +type DIO env c = RIO (DBusEnv env c) + +instance HasClient (DBusEnv SimpleApp) where + clientL = lens dClient (\x y -> x {dClient = y}) + +instance SafeClient c => HasLogFunc (DBusEnv SimpleApp c) where + logFuncL = lens dEnv (\x y -> x {dEnv = y}) . logFuncL + +withDIO + :: (MonadUnliftIO m, MonadReader env m, SafeClient c) + => c + -> DIO env c a + -> m a +withDIO cl x = do + env <- ask + runRIO (DBusEnv cl env) x + +class HasClient env where + clientL :: SafeClient c => Lens' (env c) c + -------------------------------------------------------------------------------- -- Methods type MethodBody = Either T.Text [Variant] -callMethod' :: (MonadUnliftIO m, SafeClient c) => c -> MethodCall -> m MethodBody -callMethod' cl = - liftIO - . fmap (bimap (T.pack . methodErrorMessage) methodReturnBody) - . call (toClient cl) +callMethod' + :: (SafeClient c, MonadUnliftIO m, MonadReader (env c) m, HasClient env) + => MethodCall + -> m MethodBody +callMethod' mc = do + cl <- toClient <$> view clientL + liftIO $ bimap (T.pack . methodErrorMessage) methodReturnBody <$> call cl mc callMethod - :: (MonadUnliftIO m, SafeClient c) - => c - -> BusName + :: (SafeClient c, MonadUnliftIO m, MonadReader (env c) m, HasClient env) + => BusName -> ObjectPath -> InterfaceName -> MemberName -> m MethodBody -callMethod client bus path iface = callMethod' client . methodCallBus bus path iface +callMethod bus path iface = callMethod' . methodCallBus bus path iface methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall methodCallBus b p i m = @@ -136,12 +165,16 @@ dbusInterface :: InterfaceName dbusInterface = interfaceName_ "org.freedesktop.DBus" callGetNameOwner - :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c) - => c - -> BusName + :: ( SafeClient c + , MonadUnliftIO m + , MonadReader (env c) m + , HasClient env + , HasLogFunc (env c) + ) + => BusName -> m (Maybe BusName) -callGetNameOwner cl name = do - res <- callMethod' cl mc +callGetNameOwner name = do + res <- callMethod' mc case res of Left err -> do logError $ Utf8Builder $ encodeUtf8Builder err @@ -170,13 +203,19 @@ bodyToMaybe = either (const Nothing) fromSingletonVariant type SignalCallback m = [Variant] -> m () addMatchCallback - :: (MonadUnliftIO m, SafeClient c) + :: ( MonadReader (env c) m + , HasLogFunc (env c) + , MonadUnliftIO m + , SafeClient c + , HasClient env + ) => MatchRule -> SignalCallback m - -> c -> m SignalHandler -addMatchCallback rule cb cl = withRunInIO $ \run -> do - addMatch (toClient cl) rule $ run . cb . signalBody +addMatchCallback rule cb = do + cl <- toClient <$> view clientL + withRunInIO $ \run -> do + addMatch cl rule $ run . cb . signalBody matchSignal :: Maybe BusName @@ -193,15 +232,19 @@ matchSignal b p i m = } matchSignalFull - :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c) - => c - -> BusName + :: ( MonadReader (env c) m + , HasLogFunc (env c) + , MonadUnliftIO m + , SafeClient c + , HasClient env + ) + => BusName -> Maybe ObjectPath -> Maybe InterfaceName -> Maybe MemberName -> m (Maybe MatchRule) -matchSignalFull client b p i m = do - res <- callGetNameOwner client b +matchSignalFull b p i m = do + res <- callGetNameOwner b case res of Just o -> return $ Just $ matchSignal (Just o) p i m Nothing -> do @@ -229,15 +272,20 @@ propertySignal :: MemberName propertySignal = memberName_ "PropertiesChanged" callPropertyGet - :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c) + :: ( HasClient env + , MonadReader (env c) m + , HasLogFunc (env c) + , MonadUnliftIO m + , SafeClient c + ) => BusName -> ObjectPath -> InterfaceName -> MemberName - -> c -> m [Variant] -callPropertyGet bus path iface property cl = do - res <- liftIO $ getProperty (toClient cl) $ methodCallBus bus path iface property +callPropertyGet bus path iface property = do + cl <- toClient <$> view clientL + res <- liftIO $ getProperty cl $ methodCallBus bus path iface property case res of Left err -> do logError $ displayBytesUtf8 $ BC.pack $ methodErrorMessage err @@ -249,13 +297,17 @@ matchProperty b p = matchSignal b p (Just propertyInterface) (Just propertySignal) matchPropertyFull - :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c) - => c - -> BusName + :: ( MonadReader (env c) m + , HasLogFunc (env c) + , MonadUnliftIO m + , SafeClient c + , HasClient env + ) + => BusName -> Maybe ObjectPath -> m (Maybe MatchRule) -matchPropertyFull cl b p = - matchSignalFull cl b p (Just propertyInterface) (Just propertySignal) +matchPropertyFull b p = + matchSignalFull b p (Just propertyInterface) (Just propertySignal) data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show) @@ -301,13 +353,17 @@ omInterfacesRemoved :: MemberName omInterfacesRemoved = memberName_ "InterfacesRemoved" callGetManagedObjects - :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c) - => c - -> BusName + :: ( MonadReader (env c) m + , HasLogFunc (env c) + , MonadUnliftIO m + , SafeClient c + , HasClient env + ) + => BusName -> ObjectPath -> m ObjectTree -callGetManagedObjects cl bus path = do - res <- callMethod cl bus path omInterface getManagedObjects +callGetManagedObjects bus path = do + res <- callMethod bus path omInterface getManagedObjects case res of Left err -> do logError $ Utf8Builder $ encodeUtf8Builder err @@ -315,15 +371,19 @@ callGetManagedObjects cl bus path = do Right v -> return $ fromMaybe M.empty $ fromSingletonVariant v addInterfaceChangedListener - :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c) + :: ( MonadReader (env c) m + , HasLogFunc (env c) + , MonadUnliftIO m + , SafeClient c + , HasClient env + ) => BusName -> MemberName -> ObjectPath -> SignalCallback m - -> c -> m (Maybe SignalHandler) -addInterfaceChangedListener bus prop path sc cl = do - res <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop) +addInterfaceChangedListener bus prop path sc = do + res <- matchSignalFull bus (Just path) (Just omInterface) (Just prop) case res of Nothing -> do logError $ @@ -334,28 +394,36 @@ addInterfaceChangedListener bus prop path sc cl = do <> " on bus " <> bus_ return Nothing - Just rule -> Just <$> addMatchCallback rule sc cl + Just rule -> Just <$> addMatchCallback rule sc where bus_ = "'" <> displayBusName bus <> "'" path_ = "'" <> displayObjectPath path <> "'" prop_ = "'" <> displayMemberName prop <> "'" addInterfaceAddedListener - :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c) + :: ( MonadReader (env c) m + , HasLogFunc (env c) + , MonadUnliftIO m + , SafeClient c + , HasClient env + ) => BusName -> ObjectPath -> SignalCallback m - -> c -> m (Maybe SignalHandler) addInterfaceAddedListener bus = addInterfaceChangedListener bus omInterfacesAdded addInterfaceRemovedListener - :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c) + :: ( MonadReader (env c) m + , HasLogFunc (env c) + , MonadUnliftIO m + , SafeClient c + , HasClient env + ) => BusName -> ObjectPath -> SignalCallback m - -> c -> m (Maybe SignalHandler) addInterfaceRemovedListener bus = addInterfaceChangedListener bus omInterfacesRemoved diff --git a/lib/Data/Internal/XIO.hs b/lib/Data/Internal/XIO.hs index e3bf816..005b8c4 100644 --- a/lib/Data/Internal/XIO.hs +++ b/lib/Data/Internal/XIO.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -404,9 +406,15 @@ data XEnv = XEnv instance HasLogFunc XEnv where logFuncL = lens xLogFun (\x y -> x {xLogFun = y}) +instance SafeClient c => HasLogFunc (DBusEnv XEnv c) where + logFuncL = lens dEnv (\x y -> x {dEnv = y}) . logFuncL + instance HasProcessContext XEnv where processContextL = lens xProcCxt (\x y -> x {xProcCxt = y}) +instance HasClient (DBusEnv XEnv) where + clientL = lens dClient (\x y -> x {dClient = y}) + data XParams = XParams { xpLogLevel :: LogLevel , xpFeatures :: XPFeatures @@ -865,8 +873,8 @@ testDBusDep_ :: SafeClient c => c -> DBusDependency_ c -> XIO MResult_ testDBusDep_ c d = memoizeMVar $ testDBusDepNoCache_ c d testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> XIO Result_ -testDBusDepNoCache_ cl (Bus _ bus) = io $ do - ret <- callMethod cl queryBus queryPath queryIface queryMem +testDBusDepNoCache_ cl (Bus _ bus) = do + ret <- withDIO cl $ callMethod queryBus queryPath queryIface queryMem return $ case ret of Left e -> Left [Msg LevelError e] Right b -> @@ -885,8 +893,10 @@ testDBusDepNoCache_ cl (Bus _ bus) = io $ do queryMem = memberName_ "ListNames" bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [T.Text] bodyGetNames _ = [] -testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = io $ do - ret <- callMethod cl busname objpath introspectInterface introspectMethod +testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = do + ret <- + withDIO cl $ + callMethod busname objpath introspectInterface introspectMethod return $ case ret of Left e -> Left [Msg LevelError e] Right body -> procBody body @@ -1001,8 +1011,9 @@ sometimesDBus -> Sometimes a sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c +-- TODO do I need to hardcode XEnv? sometimesEndpoint - :: (SafeClient c, MonadIO m) + :: (HasClient (DBusEnv env), SafeClient c, MonadReader env m, MonadUnliftIO m) => T.Text -> T.Text -> [Fulfillment] @@ -1016,7 +1027,7 @@ sometimesEndpoint fn name ful busname path iface mem cl = sometimesDBus cl fn name deps cmd where deps = Only_ $ Endpoint ful busname path iface $ Method_ mem - cmd c = io $ void $ callMethod c busname path iface mem + cmd c = void $ withDIO c $ callMethod busname path iface mem -------------------------------------------------------------------------------- -- Dependency Tree Constructors diff --git a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs index 7495da2..a6796c5 100644 --- a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs +++ b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- @@ -128,15 +129,24 @@ exportClevoKeyboard = [stateFileDep, brightnessFileDep] clevoKeyboardConfig -clevoKeyboardControls :: MonadUnliftIO m => Maybe SesClient -> BrightnessControls m +clevoKeyboardControls + :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m) + => Maybe SesClient + -> BrightnessControls m clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig -callGetBrightnessCK :: MonadUnliftIO m => SesClient -> m (Maybe Brightness) +callGetBrightnessCK + :: (SafeClient c, HasClient env, MonadReader (env c) m, MonadUnliftIO m) + => m (Maybe Brightness) callGetBrightnessCK = callGetBrightness clevoKeyboardConfig matchSignalCK - :: MonadUnliftIO m + :: ( SafeClient c + , HasLogFunc (env c) + , HasClient env + , MonadReader (env c) m + , MonadUnliftIO m + ) => (Maybe Brightness -> m ()) - -> SesClient -> m () matchSignalCK = matchSignal clevoKeyboardConfig diff --git a/lib/XMonad/Internal/DBus/Brightness/Common.hs b/lib/XMonad/Internal/DBus/Brightness/Common.hs index 4ef5e9d..f0cf6dd 100644 --- a/lib/XMonad/Internal/DBus/Brightness/Common.hs +++ b/lib/XMonad/Internal/DBus/Brightness/Common.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} @@ -22,7 +23,6 @@ import Data.Internal.DBus import Data.Internal.XIO import RIO import qualified RIO.Text as T -import XMonad.Core (io) import XMonad.Internal.DBus.Common -------------------------------------------------------------------------------- @@ -54,7 +54,7 @@ data BrightnessControls m = BrightnessControls } brightnessControls - :: MonadUnliftIO m + :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m) => XPQuery -> BrightnessConfig m a b -> Maybe SesClient @@ -70,26 +70,35 @@ brightnessControls q bc cl = cb = callBacklight q cl bc callGetBrightness - :: (MonadUnliftIO m, SafeClient c, Num n) + :: ( HasClient env + , MonadReader (env c) m + , MonadUnliftIO m + , SafeClient c + , Num n + ) => BrightnessConfig m a b - -> c -> m (Maybe n) -callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} client = +callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} = either (const Nothing) bodyGetBrightness - <$> callMethod client xmonadBusName p i memGet + <$> callMethod xmonadBusName p i memGet signalDep :: BrightnessConfig m a b -> DBusDependency_ SesClient signalDep BrightnessConfig {bcPath = p, bcInterface = i} = Endpoint [] xmonadBusName p i $ Signal_ memCur matchSignal - :: (MonadUnliftIO m, SafeClient c, Num n) + :: ( HasClient env + , HasLogFunc (env c) + , MonadReader (env c) m + , MonadUnliftIO m + , SafeClient c + , Num n + ) => BrightnessConfig m a b -> (Maybe n -> m ()) - -> c -> m () matchSignal BrightnessConfig {bcPath = p, bcInterface = i} cb = - void . addMatchCallback brMatcher (cb . bodyGetBrightness) + void $ addMatchCallback brMatcher (cb . bodyGetBrightness) where -- TODO add busname to this brMatcher = @@ -166,27 +175,18 @@ emitBrightness BrightnessConfig {bcPath = p, bcInterface = i} client cur = sig = signal p i memCur callBacklight - :: MonadUnliftIO m + :: (MonadReader env m, HasClient (DBusEnv env), MonadUnliftIO m) => XPQuery -> Maybe SesClient -> BrightnessConfig m a b -> T.Text -> MemberName -> Sometimes (m ()) -callBacklight - q - cl - BrightnessConfig - { bcPath = p - , bcInterface = i - , bcName = n - } - controlName - m = - Sometimes (T.unwords [n, controlName]) q [Subfeature root "method call"] - where - root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadBusName p i $ Method_ m) cl - cmd c = io $ void $ callMethod c xmonadBusName p i m +callBacklight q cl BrightnessConfig {bcPath = p, bcInterface = i, bcName = n} controlName m = + Sometimes (T.unwords [n, controlName]) q [Subfeature root "method call"] + where + root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadBusName p i $ Method_ m) cl + cmd c = void $ withDIO c $ callMethod xmonadBusName p i m bodyGetBrightness :: Num a => [Variant] -> Maybe a bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32) diff --git a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs index b4ea2ec..eaf0a18 100644 --- a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs +++ b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- @@ -114,15 +115,24 @@ exportIntelBacklight = [curFileDep, maxFileDep] intelBacklightConfig -intelBacklightControls :: MonadUnliftIO m => Maybe SesClient -> BrightnessControls m +intelBacklightControls + :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m) + => Maybe SesClient + -> BrightnessControls m intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig -callGetBrightnessIB :: MonadUnliftIO m => SesClient -> m (Maybe Brightness) +callGetBrightnessIB + :: (SafeClient c, HasClient env, MonadReader (env c) m, MonadUnliftIO m) + => m (Maybe Brightness) callGetBrightnessIB = callGetBrightness intelBacklightConfig matchSignalIB - :: MonadUnliftIO m + :: ( SafeClient c + , HasLogFunc (env c) + , HasClient env + , MonadReader (env c) m + , MonadUnliftIO m + ) => (Maybe Brightness -> m ()) - -> SesClient -> m () matchSignalIB = matchSignal intelBacklightConfig diff --git a/lib/XMonad/Internal/DBus/Removable.hs b/lib/XMonad/Internal/DBus/Removable.hs index 1a228c1..2879465 100644 --- a/lib/XMonad/Internal/DBus/Removable.hs +++ b/lib/XMonad/Internal/DBus/Removable.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- @@ -80,17 +81,31 @@ playSoundMaybe p b = when b $ io $ playSound p -- If it not already, we won't see any signals from the dbus until it is -- started (it will work after it is started however). It seems safe to simply -- enable the udisks2 service at boot; however this is not default behavior. -listenDevices :: MonadUnliftIO m => SysClient -> m () +listenDevices + :: ( HasClient (DBusEnv env) + , HasLogFunc (DBusEnv env SysClient) + , MonadReader env m + , MonadUnliftIO m + ) + => SysClient + -> m () listenDevices cl = do addMatch' memAdded driveInsertedSound addedHasDrive addMatch' memRemoved driveRemovedSound removedHasDrive where addMatch' m p f = do let rule = ruleUdisks {matchMember = Just m} - void $ addMatchCallback rule (playSoundMaybe p . f) cl + void $ withDIO cl $ addMatchCallback rule (playSoundMaybe p . f) -runRemovableMon :: MonadUnliftIO m => Maybe SysClient -> Sometimes (m ()) +runRemovableMon + :: ( HasClient (DBusEnv env) + , HasLogFunc (DBusEnv env SysClient) + , MonadReader env m + , MonadUnliftIO m + ) + => Maybe SysClient + -> Sometimes (m ()) runRemovableMon cl = - sometimesDBus cl "removeable device monitor" "dbus monitor" deps $ io . listenDevices + sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices where deps = toAnd_ addedDep removedDep diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index 96e1ca8..541d096 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/lib/XMonad/Internal/DBus/Screensaver.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- @@ -124,7 +125,10 @@ exportScreensaver ses = bus = Bus [] xmonadBusName ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable -callToggle :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ()) +callToggle + :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m) + => Maybe SesClient + -> Sometimes (m ()) callToggle = sometimesEndpoint "screensaver toggle" @@ -135,18 +139,26 @@ callToggle = interface memToggle -callQuery :: MonadUnliftIO m => SesClient -> m (Maybe SSState) -callQuery ses = do - reply <- callMethod ses xmonadBusName ssPath interface memQuery +callQuery + :: (HasClient env, MonadReader (env SesClient) m, MonadUnliftIO m) + => m (Maybe SSState) +callQuery = do + reply <- callMethod xmonadBusName ssPath interface memQuery return $ either (const Nothing) bodyGetCurrentState reply -matchSignal :: MonadUnliftIO m => (Maybe SSState -> m ()) -> SesClient -> m () -matchSignal cb ses = +matchSignal + :: ( HasLogFunc (env SesClient) + , HasClient env + , MonadReader (env SesClient) m + , MonadUnliftIO m + ) + => (Maybe SSState -> m ()) + -> m () +matchSignal cb = void $ addMatchCallback ruleCurrentState (cb . bodyGetCurrentState) - ses ssSignalDep :: DBusDependency_ SesClient ssSignalDep = Endpoint [] xmonadBusName ssPath interface $ Signal_ memState diff --git a/lib/Xmobar/Plugins/BacklightCommon.hs b/lib/Xmobar/Plugins/BacklightCommon.hs index 14c8e4c..867e13f 100644 --- a/lib/Xmobar/Plugins/BacklightCommon.hs +++ b/lib/Xmobar/Plugins/BacklightCommon.hs @@ -14,15 +14,15 @@ import Xmobar.Plugins.Common startBacklight :: (MonadUnliftIO m, RealFrac a) => Utf8Builder - -> ((Maybe a -> RIO SimpleApp ()) -> SesClient -> RIO SimpleApp ()) - -> (SesClient -> RIO SimpleApp (Maybe a)) + -> ((Maybe a -> DIO SimpleApp SesClient ()) -> DIO SimpleApp SesClient ()) + -> DIO SimpleApp SesClient (Maybe a) -> T.Text -> Callback -> m () startBacklight name matchSignal callGetBrightness icon cb = do - withDBusClientConnection cb name $ \c -> do - matchSignal dpy c - dpy =<< callGetBrightness c + withDBusClientConnection cb name $ \c -> withDIO c $ do + matchSignal dpy + dpy =<< callGetBrightness where formatBrightness b = return $ T.concat [icon, T.pack $ show (round b :: Integer), "%"] dpy = displayMaybe cb formatBrightness diff --git a/lib/Xmobar/Plugins/Bluetooth.hs b/lib/Xmobar/Plugins/Bluetooth.hs index ef70c68..4666048 100644 --- a/lib/Xmobar/Plugins/Bluetooth.hs +++ b/lib/Xmobar/Plugins/Bluetooth.hs @@ -76,19 +76,19 @@ startAdapter startAdapter is cs cb cl = do state <- newMVar emptyState let dpy = displayIcon cb (iconFormatter is cs) - mapRIO (BTEnv state dpy) $ do - ot <- getBtObjectTree cl + mapRIO (BTEnv cl state dpy) $ do + ot <- getBtObjectTree case findAdapter ot of Nothing -> logError "could not find bluetooth adapter" Just adapter -> do -- set up adapter - initAdapter adapter cl - void $ addAdaptorListener adapter cl + initAdapter adapter + void $ addAdaptorListener adapter -- set up devices on the adapter (and listeners for adding/removing devices) let devices = findDevices adapter ot - addDeviceAddedListener adapter cl - addDeviceRemovedListener adapter cl - forM_ devices $ \d -> addAndInitDevice d cl + addDeviceAddedListener adapter + addDeviceRemovedListener adapter + forM_ devices $ \d -> addAndInitDevice d -- after setting things up, show the icon based on the initialized state dpy @@ -121,16 +121,20 @@ iconFormatter (iconConn, iconDisc) cs powered connected = -- is to track the shared state of the bluetooth adaptor and its devices using -- an MVar. -data BTEnv = BTEnv - { btState :: !(MVar BtState) +data BTEnv c = BTEnv + { btClient :: !c + , btState :: !(MVar BtState) , btDisplay :: !(BTIO ()) , btEnv :: !SimpleApp } -instance HasLogFunc BTEnv where +instance HasClient BTEnv where + clientL = lens btClient (\x y -> x {btClient = y}) + +instance HasLogFunc (BTEnv a) where logFuncL = lens btEnv (\x y -> x {btEnv = y}) . logFuncL -type BTIO = RIO BTEnv +type BTIO = RIO (BTEnv SysClient) data BTDevice = BTDevice { btDevConnected :: Maybe Bool @@ -183,34 +187,43 @@ splitPathNoRoot :: ObjectPath -> [FilePath] splitPathNoRoot = dropWhile (== "/") . splitDirectories . formatObjectPath getBtObjectTree - :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) - => SysClient - -> m ObjectTree -getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath + :: ( HasClient env + , SafeClient c + , MonadReader (env c) m + , HasLogFunc (env c) + , MonadUnliftIO m + ) + => m ObjectTree +getBtObjectTree = callGetManagedObjects btBus btOMPath btOMPath :: ObjectPath btOMPath = objectPath_ "/" addBtOMListener - :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) + :: ( HasClient env + , SafeClient c + , MonadReader (env c) m + , HasLogFunc (env c) + , MonadUnliftIO m + ) => SignalCallback m - -> SysClient -> m () -addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc +addBtOMListener sc = void $ addInterfaceAddedListener btBus btOMPath sc -addDeviceAddedListener :: ObjectPath -> SysClient -> BTIO () -addDeviceAddedListener adapter client = addBtOMListener addDevice client +addDeviceAddedListener :: ObjectPath -> BTIO () +addDeviceAddedListener adapter = addBtOMListener addDevice where addDevice = pathCallback adapter $ \d -> - addAndInitDevice d client + addAndInitDevice d -addDeviceRemovedListener :: ObjectPath -> SysClient -> BTIO () -addDeviceRemovedListener adapter sys = - addBtOMListener remDevice sys +addDeviceRemovedListener :: ObjectPath -> BTIO () +addDeviceRemovedListener adapter = + addBtOMListener remDevice where remDevice = pathCallback adapter $ \d -> do old <- removeDevice d - forM_ old $ liftIO . removeMatch (toClient sys) . btDevSigHandler + cl <- asks btClient + forM_ old $ liftIO . removeMatch (toClient cl) . btDevSigHandler pathCallback :: ObjectPath -> (ObjectPath -> BTIO ()) -> SignalCallback BTIO pathCallback adapter f [device, _] = forM_ (fromVariant device) $ \d -> do @@ -220,9 +233,9 @@ pathCallback _ _ _ = return () -------------------------------------------------------------------------------- -- Adapter -initAdapter :: ObjectPath -> SysClient -> BTIO () -initAdapter adapter client = do - reply <- callGetPowered adapter client +initAdapter :: ObjectPath -> BTIO () +initAdapter adapter = do + reply <- callGetPowered adapter logInfo $ "initializing adapter at path " <> adapter_ -- TODO this could fail if the variant is something weird; the only -- indication I will get is "NA" @@ -231,24 +244,33 @@ initAdapter adapter client = do adapter_ = displayWrapQuote $ displayObjectPath adapter matchBTProperty - :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) - => SysClient - -> ObjectPath + :: ( SafeClient c + , HasClient env + , MonadReader (env c) m + , HasLogFunc (env c) + , MonadUnliftIO m + ) + => ObjectPath -> m (Maybe MatchRule) -matchBTProperty sys p = matchPropertyFull sys btBus (Just p) +matchBTProperty p = matchPropertyFull btBus (Just p) withBTPropertyRule - :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, IsVariant a) - => SysClient - -> ObjectPath + :: ( SafeClient c + , MonadReader (env c) m + , HasLogFunc (env c) + , HasClient env + , MonadUnliftIO m + , IsVariant a + ) + => ObjectPath -> (Maybe a -> m ()) -> InterfaceName -> T.Text -> m (Maybe SignalHandler) -withBTPropertyRule cl path update iface prop = do - res <- matchBTProperty cl path +withBTPropertyRule path update iface prop = do + res <- matchBTProperty path case res of - Just rule -> Just <$> addMatchCallback rule (signalToUpdate . matchConnected) cl + Just rule -> Just <$> addMatchCallback rule (signalToUpdate . matchConnected) Nothing -> do logError $ "could not add listener for prop " @@ -262,16 +284,20 @@ withBTPropertyRule cl path update iface prop = do signalToUpdate = withSignalMatch update matchConnected = matchPropertyChanged iface prop -addAdaptorListener :: ObjectPath -> SysClient -> BTIO (Maybe SignalHandler) -addAdaptorListener adaptor sys = - withBTPropertyRule sys adaptor procMatch adapterInterface adaptorPowered +addAdaptorListener :: ObjectPath -> BTIO (Maybe SignalHandler) +addAdaptorListener adaptor = + withBTPropertyRule adaptor procMatch adapterInterface adaptorPowered where procMatch = beforeDisplay . putPowered callGetPowered - :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) + :: ( HasClient env + , MonadReader (env c) m + , HasLogFunc (env c) + , SafeClient c + , MonadUnliftIO m + ) => ObjectPath - -> SysClient -> m [Variant] callGetPowered adapter = callPropertyGet btBus adapter adapterInterface $ @@ -293,20 +319,20 @@ adaptorPowered = "Powered" -------------------------------------------------------------------------------- -- Devices -addAndInitDevice :: ObjectPath -> SysClient -> BTIO () -addAndInitDevice device client = do - res <- addDeviceListener device client +addAndInitDevice :: ObjectPath -> BTIO () +addAndInitDevice device = do + res <- addDeviceListener device case res of Just handler -> do logInfo $ "initializing device at path " <> device_ - initDevice handler device client + initDevice handler device Nothing -> logError $ "could not initialize device at path " <> device_ where device_ = displayWrapQuote $ displayObjectPath device -initDevice :: SignalHandler -> ObjectPath -> SysClient -> BTIO () -initDevice sh device sys = do - reply <- callGetConnected device sys +initDevice :: SignalHandler -> ObjectPath -> BTIO () +initDevice sh device = do + reply <- callGetConnected device void $ insertDevice device $ BTDevice @@ -314,16 +340,20 @@ initDevice sh device sys = do , btDevSigHandler = sh } -addDeviceListener :: ObjectPath -> SysClient -> BTIO (Maybe SignalHandler) -addDeviceListener device sys = - withBTPropertyRule sys device procMatch devInterface devConnected +addDeviceListener :: ObjectPath -> BTIO (Maybe SignalHandler) +addDeviceListener device = + withBTPropertyRule device procMatch devInterface devConnected where procMatch = beforeDisplay . void . updateDevice device callGetConnected - :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) + :: ( SafeClient c + , HasClient env + , MonadReader (env c) m + , HasLogFunc (env c) + , MonadUnliftIO m + ) => ObjectPath - -> SysClient -> m [Variant] callGetConnected p = callPropertyGet btBus p devInterface $ diff --git a/lib/Xmobar/Plugins/Common.hs b/lib/Xmobar/Plugins/Common.hs index aaabde7..0fe2a31 100644 --- a/lib/Xmobar/Plugins/Common.hs +++ b/lib/Xmobar/Plugins/Common.hs @@ -32,18 +32,23 @@ data Colors = Colors deriving (Eq, Show, Read) startListener - :: (MonadUnliftIO m, SafeClient c, IsVariant a) + :: ( HasLogFunc (env c) + , HasClient env + , MonadReader (env c) m + , MonadUnliftIO m + , SafeClient c + , IsVariant a + ) => MatchRule - -> (c -> m [Variant]) + -> m [Variant] -> ([Variant] -> SignalMatch a) -> (a -> m T.Text) -> Callback - -> c -> m () -startListener rule getProp fromSignal toColor cb client = do - reply <- getProp client +startListener rule getProp fromSignal toColor cb = do + reply <- getProp displayMaybe cb toColor $ fromSingletonVariant reply - void $ addMatchCallback rule (procMatch . fromSignal) client + void $ addMatchCallback rule (procMatch . fromSignal) where procMatch = procSignalMatch cb toColor diff --git a/lib/Xmobar/Plugins/Device.hs b/lib/Xmobar/Plugins/Device.hs index 3ce53fc..89ae361 100644 --- a/lib/Xmobar/Plugins/Device.hs +++ b/lib/Xmobar/Plugins/Device.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} -------------------------------------------------------------------------------- -- Device plugin @@ -44,8 +45,11 @@ devDep = Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface $ Method_ getByIP -getDevice :: MonadUnliftIO m => SysClient -> T.Text -> m (Maybe ObjectPath) -getDevice sys iface = bodyToMaybe <$> callMethod' sys mc +getDevice + :: (SafeClient c, HasClient env, MonadReader (env c) m, MonadUnliftIO m) + => T.Text + -> m (Maybe ObjectPath) +getDevice iface = bodyToMaybe <$> callMethod' mc where mc = (methodCallBus networkManagerBus nmPath nmInterface getByIP) @@ -53,9 +57,13 @@ getDevice sys iface = bodyToMaybe <$> callMethod' sys mc } getDeviceConnected - :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) + :: ( SafeClient c + , HasClient env + , MonadReader (env c) m + , HasLogFunc (env c) + , MonadUnliftIO m + ) => ObjectPath - -> SysClient -> m [Variant] getDeviceConnected path = callPropertyGet networkManagerBus path nmDeviceInterface $ @@ -68,14 +76,14 @@ matchStatus = matchPropertyChanged nmDeviceInterface devSignal instance Exec Device where alias (Device (iface, _, _)) = T.unpack iface start (Device (iface, text, colors)) cb = - withDBusClientConnection cb logName $ \sys -> do - path <- getDevice sys iface - displayMaybe' cb (listener sys) path + withDBusClientConnection cb logName $ \(sys :: SysClient) -> withDIO sys $ do + path <- getDevice iface + displayMaybe' cb listener path where logName = "device@" <> Utf8Builder (encodeUtf8Builder iface) - listener sys path = do - res <- matchPropertyFull sys networkManagerBus (Just path) + listener path = do + res <- matchPropertyFull networkManagerBus (Just path) case res of - Just rule -> startListener rule (getDeviceConnected path) matchStatus chooseColor' cb sys + Just rule -> startListener rule (getDeviceConnected path) matchStatus chooseColor' cb Nothing -> logError "could not start listener" chooseColor' = return . (\s -> colorText colors s text) . (> 1) diff --git a/lib/Xmobar/Plugins/Screensaver.hs b/lib/Xmobar/Plugins/Screensaver.hs index 8c333b7..457ec2a 100644 --- a/lib/Xmobar/Plugins/Screensaver.hs +++ b/lib/Xmobar/Plugins/Screensaver.hs @@ -12,6 +12,7 @@ module Xmobar.Plugins.Screensaver ) where +import Data.Internal.DBus import qualified RIO.Text as T import XMonad.Internal.DBus.Screensaver import Xmobar @@ -25,8 +26,8 @@ ssAlias = "screensaver" instance Exec Screensaver where alias (Screensaver _) = T.unpack ssAlias start (Screensaver (text, colors)) cb = - withDBusClientConnection cb "screensaver" $ \sys -> do - matchSignal dpy sys - dpy =<< callQuery sys + withDBusClientConnection cb "screensaver" $ \cl -> withDIO cl $ do + matchSignal dpy + dpy =<< callQuery where dpy = displayMaybe cb $ return . (\s -> colorText colors s text) diff --git a/lib/Xmobar/Plugins/VPN.hs b/lib/Xmobar/Plugins/VPN.hs index b7b52df..fa054fa 100644 --- a/lib/Xmobar/Plugins/VPN.hs +++ b/lib/Xmobar/Plugins/VPN.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- @@ -32,11 +33,12 @@ instance Exec VPN where alias (VPN _) = T.unpack vpnAlias start (VPN (text, colors)) cb = withDBusClientConnection cb "VPN" $ \c -> do - state <- initState c let dpy = displayMaybe cb iconFormatter . Just =<< readState - mapRIO (VEnv state dpy) $ do - vpnAddedListener addedCallback c - vpnRemovedListener removedCallback c + s <- newMVar S.empty + mapRIO (VEnv c s dpy) $ do + initState + vpnAddedListener addedCallback + vpnRemovedListener removedCallback dpy where iconFormatter b = return $ colorText colors b text @@ -48,28 +50,30 @@ 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 +data VEnv c = VEnv + { vClient :: !c + , vState :: !MutableVPNState , vDisplay :: !(VIO ()) , vEnv :: !SimpleApp } -instance HasLogFunc VEnv where +instance HasLogFunc (VEnv SysClient) where logFuncL = lens vEnv (\x y -> x {vEnv = y}) . logFuncL -type VIO = RIO VEnv +instance HasClient VEnv where + clientL = lens vClient (\x y -> x {vClient = y}) + +type VIO = RIO (VEnv SysClient) type VPNState = S.Set ObjectPath type MutableVPNState = MVar VPNState -initState - :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) - => SysClient - -> m MutableVPNState -initState client = do - ot <- getVPNObjectTree client - newMVar $ findTunnels ot +initState :: VIO () +initState = do + ot <- getVPNObjectTree + s <- asks vState + putMVar s $ findTunnels ot readState :: VIO Bool readState = fmap (not . null) . readMVar =<< asks vState @@ -86,27 +90,39 @@ beforeDisplay f = f >> join (asks vDisplay) -- Tunnel Device Detection getVPNObjectTree - :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) - => SysClient - -> m ObjectTree -getVPNObjectTree sys = callGetManagedObjects sys vpnBus vpnPath + :: ( SafeClient c + , HasClient env + , MonadReader (env c) m + , HasLogFunc (env c) + , MonadUnliftIO m + ) + => m ObjectTree +getVPNObjectTree = callGetManagedObjects vpnBus vpnPath findTunnels :: ObjectTree -> VPNState findTunnels = S.fromList . M.keys . M.filter (elem vpnDeviceTun . M.keys) vpnAddedListener - :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) + :: ( SafeClient c + , HasClient env + , MonadReader (env c) m + , HasLogFunc (env c) + , MonadUnliftIO m + ) => SignalCallback m - -> SysClient -> m () -vpnAddedListener cb = void . addInterfaceAddedListener vpnBus vpnPath cb +vpnAddedListener cb = void $ addInterfaceAddedListener vpnBus vpnPath cb vpnRemovedListener - :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) + :: ( SafeClient c + , HasClient env + , MonadReader (env c) m + , HasLogFunc (env c) + , MonadUnliftIO m + ) => SignalCallback m - -> SysClient -> m () -vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb +vpnRemovedListener cb = void $ addInterfaceRemovedListener vpnBus vpnPath cb addedCallback :: SignalCallback VIO addedCallback [device, added] =