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