ENH generalize io monads in dbus

This commit is contained in:
Nathan Dwarshuis 2022-12-30 16:29:50 -05:00
parent adf0257533
commit 993b9e731a
1 changed files with 39 additions and 37 deletions

View File

@ -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