From 993b9e731af827b6c0e6483f2a2b5f47b284f654 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Fri, 30 Dec 2022 16:29:50 -0500
Subject: [PATCH] ENH generalize io monads in dbus

---
 lib/Data/Internal/DBus.hs | 76 ++++++++++++++++++++-------------------
 1 file changed, 39 insertions(+), 37 deletions(-)

diff --git a/lib/Data/Internal/DBus.hs b/lib/Data/Internal/DBus.hs
index 7015065..51b2698 100644
--- a/lib/Data/Internal/DBus.hs
+++ b/lib/Data/Internal/DBus.hs
@@ -28,13 +28,13 @@ module Data.Internal.DBus
   )
 where
 
-import Control.Exception
 import Control.Monad
 import DBus
 import DBus.Client
 import Data.Bifunctor
 import qualified Data.Map.Strict as M
 import Data.Maybe
+import RIO
 import qualified RIO.Text as T
 
 --------------------------------------------------------------------------------
@@ -43,23 +43,23 @@ import qualified RIO.Text as T
 class SafeClient c where
   toClient :: c -> Client
 
-  getDBusClient :: IO (Maybe c)
+  getDBusClient :: MonadUnliftIO m => m (Maybe c)
 
-  disconnectDBusClient :: c -> IO ()
-  disconnectDBusClient = disconnect . toClient
+  disconnectDBusClient :: MonadUnliftIO m => c -> m ()
+  disconnectDBusClient = liftIO . disconnect . toClient
 
-  withDBusClient :: (c -> IO a) -> IO (Maybe a)
+  withDBusClient :: MonadUnliftIO m => (c -> m a) -> m (Maybe a)
   withDBusClient f = do
     client <- getDBusClient
     forM client $ \c -> do
       r <- f c
-      disconnect (toClient c)
+      liftIO $ disconnect (toClient c)
       return r
 
-  withDBusClient_ :: (c -> IO ()) -> IO ()
+  withDBusClient_ :: MonadUnliftIO m => (c -> m ()) -> m ()
   withDBusClient_ = void . withDBusClient
 
-  fromDBusClient :: (c -> a) -> IO (Maybe a)
+  fromDBusClient :: MonadUnliftIO m => (c -> a) -> m (Maybe a)
   fromDBusClient f = withDBusClient (return . f)
 
 newtype SysClient = SysClient Client
@@ -76,11 +76,11 @@ instance SafeClient SesClient where
 
   getDBusClient = fmap SesClient <$> getDBusClient' False
 
-getDBusClient' :: Bool -> IO (Maybe Client)
+getDBusClient' :: MonadUnliftIO m => Bool -> m (Maybe Client)
 getDBusClient' sys = do
-  res <- try $ if sys then connectSystem else connectSession
+  res <- try $ liftIO $ if sys then connectSystem else connectSession
   case res of
-    Left e -> putStrLn (clientErrorMessage e) >> return Nothing
+    Left e -> liftIO $ putStrLn (clientErrorMessage e) >> return Nothing
     Right c -> return $ Just c
 
 --------------------------------------------------------------------------------
@@ -88,19 +88,20 @@ getDBusClient' sys = do
 
 type MethodBody = Either T.Text [Variant]
 
-callMethod' :: SafeClient c => c -> MethodCall -> IO MethodBody
+callMethod' :: (MonadUnliftIO m, SafeClient c) => c -> MethodCall -> m MethodBody
 callMethod' cl =
-  fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
+  liftIO
+    . fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
     . call (toClient cl)
 
 callMethod
-  :: SafeClient c
+  :: (MonadUnliftIO m, SafeClient c)
   => c
   -> BusName
   -> ObjectPath
   -> InterfaceName
   -> MemberName
-  -> IO MethodBody
+  -> m MethodBody
 callMethod client bus path iface = callMethod' client . methodCallBus bus path iface
 
 methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall
@@ -115,7 +116,7 @@ methodCallBus b p i m =
 dbusInterface :: InterfaceName
 dbusInterface = interfaceName_ "org.freedesktop.DBus"
 
-callGetNameOwner :: SafeClient c => c -> BusName -> IO (Maybe BusName)
+callGetNameOwner :: (MonadUnliftIO m, SafeClient c) => c -> BusName -> m (Maybe BusName)
 callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc
   where
     mc =
@@ -139,12 +140,12 @@ bodyToMaybe = either (const Nothing) fromSingletonVariant
 type SignalCallback = [Variant] -> IO ()
 
 addMatchCallback
-  :: SafeClient c
+  :: (MonadUnliftIO m, SafeClient c)
   => MatchRule
   -> SignalCallback
   -> c
-  -> IO SignalHandler
-addMatchCallback rule cb cl = addMatch (toClient cl) rule $ cb . signalBody
+  -> m SignalHandler
+addMatchCallback rule cb cl = liftIO . addMatch (toClient cl) rule $ cb . signalBody
 
 matchSignal
   :: Maybe BusName
@@ -161,13 +162,13 @@ matchSignal b p i m =
     }
 
 matchSignalFull
-  :: SafeClient c
+  :: (MonadUnliftIO m, SafeClient c)
   => c
   -> BusName
   -> Maybe ObjectPath
   -> Maybe InterfaceName
   -> Maybe MemberName
-  -> IO (Maybe MatchRule)
+  -> m (Maybe MatchRule)
 matchSignalFull client b p i m =
   fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b
 
@@ -181,34 +182,35 @@ propertySignal :: MemberName
 propertySignal = memberName_ "PropertiesChanged"
 
 callPropertyGet
-  :: SafeClient c
+  :: (MonadUnliftIO m, SafeClient c)
   => BusName
   -> ObjectPath
   -> InterfaceName
   -> MemberName
   -> c
-  -> IO [Variant]
+  -> m [Variant]
 callPropertyGet bus path iface property cl =
-  fmap (either (const []) (: [])) $
-    getProperty (toClient cl) $
-      methodCallBus bus path iface property
+  liftIO $
+    fmap (either (const []) (: [])) $
+      getProperty (toClient cl) $
+        methodCallBus bus path iface property
 
 matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule
 matchProperty b p =
   matchSignal b p (Just propertyInterface) (Just propertySignal)
 
 matchPropertyFull
-  :: SafeClient c
+  :: (MonadUnliftIO m, SafeClient c)
   => c
   -> BusName
   -> Maybe ObjectPath
-  -> IO (Maybe MatchRule)
+  -> m (Maybe MatchRule)
 matchPropertyFull cl b p =
   matchSignalFull cl b p (Just propertyInterface) (Just propertySignal)
 
 data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show)
 
-withSignalMatch :: (Maybe a -> IO ()) -> SignalMatch a -> IO ()
+withSignalMatch :: MonadUnliftIO m => (Maybe a -> m ()) -> SignalMatch a -> m ()
 withSignalMatch f (Match x) = f (Just x)
 withSignalMatch f Failure = f Nothing
 withSignalMatch _ NoMatch = return ()
@@ -250,43 +252,43 @@ omInterfacesRemoved :: MemberName
 omInterfacesRemoved = memberName_ "InterfacesRemoved"
 
 callGetManagedObjects
-  :: SafeClient c
+  :: (MonadUnliftIO m, SafeClient c)
   => c
   -> BusName
   -> ObjectPath
-  -> IO ObjectTree
+  -> m ObjectTree
 callGetManagedObjects cl bus path =
   either (const M.empty) (fromMaybe M.empty . fromSingletonVariant)
     <$> callMethod cl bus path omInterface getManagedObjects
 
 addInterfaceChangedListener
-  :: SafeClient c
+  :: (MonadUnliftIO m, SafeClient c)
   => BusName
   -> MemberName
   -> ObjectPath
   -> SignalCallback
   -> c
-  -> IO (Maybe SignalHandler)
+  -> m (Maybe SignalHandler)
 addInterfaceChangedListener bus prop path sc cl = do
   rule <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop)
   forM rule $ \r -> addMatchCallback r sc cl
 
 addInterfaceAddedListener
-  :: SafeClient c
+  :: (MonadUnliftIO m, SafeClient c)
   => BusName
   -> ObjectPath
   -> SignalCallback
   -> c
-  -> IO (Maybe SignalHandler)
+  -> m (Maybe SignalHandler)
 addInterfaceAddedListener bus =
   addInterfaceChangedListener bus omInterfacesAdded
 
 addInterfaceRemovedListener
-  :: SafeClient c
+  :: (MonadUnliftIO m, SafeClient c)
   => BusName
   -> ObjectPath
   -> SignalCallback
   -> c
-  -> IO (Maybe SignalHandler)
+  -> m (Maybe SignalHandler)
 addInterfaceRemovedListener bus =
   addInterfaceChangedListener bus omInterfacesRemoved