ENH generalize io monads in dbus
This commit is contained in:
parent
adf0257533
commit
993b9e731a
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue