-------------------------------------------------------------------------------- -- Common internal DBus functions module Data.Internal.DBus ( SafeClient (..) , SysClient (..) , SesClient (..) , addMatchCallback , matchProperty , matchPropertyFull , matchPropertyChanged , SignalMatch (..) , SignalCallback , MethodBody , withSignalMatch , callPropertyGet , callMethod , callMethod' , methodCallBus , callGetManagedObjects , ObjectTree , getManagedObjects , omInterface , addInterfaceAddedListener , addInterfaceRemovedListener , fromSingletonVariant , bodyToMaybe ) where 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 -------------------------------------------------------------------------------- -- Type-safe client class SafeClient c where toClient :: c -> Client getDBusClient :: MonadUnliftIO m => m (Maybe c) disconnectDBusClient :: MonadUnliftIO m => c -> m () disconnectDBusClient = liftIO . disconnect . toClient withDBusClient :: MonadUnliftIO m => (c -> m a) -> m (Maybe a) withDBusClient f = do client <- getDBusClient forM client $ \c -> do r <- f c liftIO $ disconnect (toClient c) return r withDBusClient_ :: MonadUnliftIO m => (c -> m ()) -> m () withDBusClient_ = void . withDBusClient fromDBusClient :: MonadUnliftIO m => (c -> a) -> m (Maybe a) fromDBusClient f = withDBusClient (return . f) newtype SysClient = SysClient Client instance SafeClient SysClient where toClient (SysClient cl) = cl getDBusClient = fmap SysClient <$> getDBusClient' True newtype SesClient = SesClient Client instance SafeClient SesClient where toClient (SesClient cl) = cl getDBusClient = fmap SesClient <$> getDBusClient' False getDBusClient' :: MonadUnliftIO m => Bool -> m (Maybe Client) getDBusClient' sys = do res <- try $ liftIO $ if sys then connectSystem else connectSession case res of Left e -> liftIO $ putStrLn (clientErrorMessage e) >> return Nothing Right c -> return $ Just 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 :: (MonadUnliftIO m, SafeClient c) => c -> BusName -> ObjectPath -> InterfaceName -> MemberName -> m MethodBody callMethod client bus path iface = callMethod' client . methodCallBus bus path iface methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall methodCallBus b p i m = (methodCall p i m) { methodCallDestination = Just b } -------------------------------------------------------------------------------- -- Bus names dbusInterface :: InterfaceName dbusInterface = interfaceName_ "org.freedesktop.DBus" callGetNameOwner :: (MonadUnliftIO m, SafeClient c) => c -> BusName -> m (Maybe BusName) callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc where mc = (methodCallBus dbusName dbusPath dbusInterface mem) { methodCallBody = [toVariant name] } mem = memberName_ "GetNameOwner" -------------------------------------------------------------------------------- -- Variant parsing fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a fromSingletonVariant = fromVariant <=< listToMaybe bodyToMaybe :: IsVariant a => MethodBody -> Maybe a bodyToMaybe = either (const Nothing) fromSingletonVariant -------------------------------------------------------------------------------- -- Signals type SignalCallback = [Variant] -> IO () addMatchCallback :: (MonadUnliftIO m, SafeClient c) => MatchRule -> SignalCallback -> c -> m SignalHandler addMatchCallback rule cb cl = liftIO . addMatch (toClient cl) rule $ cb . signalBody matchSignal :: Maybe BusName -> Maybe ObjectPath -> Maybe InterfaceName -> Maybe MemberName -> MatchRule matchSignal b p i m = matchAny { matchPath = p , matchSender = b , matchInterface = i , matchMember = m } matchSignalFull :: (MonadUnliftIO m, SafeClient c) => c -> BusName -> Maybe ObjectPath -> Maybe InterfaceName -> Maybe MemberName -> m (Maybe MatchRule) matchSignalFull client b p i m = fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b -------------------------------------------------------------------------------- -- Properties propertyInterface :: InterfaceName propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties" propertySignal :: MemberName propertySignal = memberName_ "PropertiesChanged" callPropertyGet :: (MonadUnliftIO m, SafeClient c) => BusName -> ObjectPath -> InterfaceName -> MemberName -> c -> m [Variant] callPropertyGet bus path iface property cl = 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 :: (MonadUnliftIO m, SafeClient c) => c -> BusName -> Maybe ObjectPath -> 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 :: MonadUnliftIO m => (Maybe a -> m ()) -> SignalMatch a -> m () withSignalMatch f (Match x) = f (Just x) withSignalMatch f Failure = f Nothing withSignalMatch _ NoMatch = return () matchPropertyChanged :: IsVariant a => InterfaceName -> T.Text -> [Variant] -> SignalMatch a matchPropertyChanged iface property [i, body, _] = let i' = (fromVariant i :: Maybe T.Text) b = toMap body in case (i', b) of (Just i'', Just b') -> if i'' == T.pack (formatInterfaceName iface) then maybe NoMatch Match $ fromVariant =<< M.lookup property b' else NoMatch _ -> Failure where toMap v = fromVariant v :: Maybe (M.Map T.Text Variant) matchPropertyChanged _ _ _ = Failure -------------------------------------------------------------------------------- -- Object Manager type ObjectTree = M.Map ObjectPath (M.Map T.Text (M.Map T.Text Variant)) omInterface :: InterfaceName omInterface = interfaceName_ "org.freedesktop.DBus.ObjectManager" getManagedObjects :: MemberName getManagedObjects = memberName_ "GetManagedObjects" omInterfacesAdded :: MemberName omInterfacesAdded = memberName_ "InterfacesAdded" omInterfacesRemoved :: MemberName omInterfacesRemoved = memberName_ "InterfacesRemoved" callGetManagedObjects :: (MonadUnliftIO m, SafeClient c) => c -> BusName -> ObjectPath -> m ObjectTree callGetManagedObjects cl bus path = either (const M.empty) (fromMaybe M.empty . fromSingletonVariant) <$> callMethod cl bus path omInterface getManagedObjects addInterfaceChangedListener :: (MonadUnliftIO m, SafeClient c) => BusName -> MemberName -> ObjectPath -> SignalCallback -> c -> 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 :: (MonadUnliftIO m, SafeClient c) => BusName -> ObjectPath -> SignalCallback -> c -> m (Maybe SignalHandler) addInterfaceAddedListener bus = addInterfaceChangedListener bus omInterfacesAdded addInterfaceRemovedListener :: (MonadUnliftIO m, SafeClient c) => BusName -> ObjectPath -> SignalCallback -> c -> m (Maybe SignalHandler) addInterfaceRemovedListener bus = addInterfaceChangedListener bus omInterfacesRemoved