ENH hold client in monad

2023-01-03 22:18:55 -05:00 · 2023-01-03 22:18:55 -05:00 · a0cdcce146
parent f95079ba5e
commit a0cdcce146
13 changed files with 385 additions and 199 deletions
--- 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
--- 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
--- 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
--- 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 =
+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
+    cmd c = void $ withDIO c $ callMethod xmonadBusName p i m

 bodyGetBrightness :: Num a => [Variant] -> Maybe a
 bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)
--- 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
--- 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
--- 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
--- 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
--- 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 $
--- 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

--- 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)
--- 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)
--- 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] =