diff --git a/lib/Data/Internal/DBus.hs b/lib/Data/Internal/DBus.hs index c18bc8d..409716e 100644 --- a/lib/Data/Internal/DBus.hs +++ b/lib/Data/Internal/DBus.hs @@ -35,6 +35,7 @@ import DBus import DBus.Client import qualified Data.ByteString.Char8 as BC import RIO +import RIO.List import qualified RIO.Map as M import qualified RIO.Text as T @@ -92,7 +93,7 @@ getDBusClient' sys = do res <- try $ liftIO $ if sys then connectSystem else connectSession case res of Left e -> do - logInfo $ Utf8Builder $ encodeUtf8Builder $ T.pack $ clientErrorMessage e + logInfo $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e return Nothing Right c -> return $ Just c @@ -151,6 +152,7 @@ callGetNameOwner cl name = do -------------------------------------------------------------------------------- -- Variant parsing +-- TODO log failures here? fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a fromSingletonVariant = fromVariant <=< listToMaybe @@ -193,8 +195,25 @@ matchSignalFull -> Maybe InterfaceName -> Maybe MemberName -> m (Maybe MatchRule) -matchSignalFull client b p i m = - fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b +matchSignalFull client b p i m = do + res <- callGetNameOwner client b + case res of + Just o -> return $ Just $ matchSignal (Just o) p i m + Nothing -> do + logError $ + "could not add signal matcher on bus " <> bus_ <> " with match: " <> match + return Nothing + where + bus_ = displayWrapQuote $ displayBusName b + iface_ = displayWrapQuote . displayInterfaceName <$> i + path_ = displayWrapQuote . displayObjectPath <$> p + mem_ = displayWrapQuote . displayMemberName <$> m + match = + displayWrapQuote $ + mconcat $ + intersperse ", " $ + mapMaybe (\(k, v) -> fmap ((k <> "=") <>) v) $ + zip ["interface", "path", "member"] [iface_, path_, mem_] -------------------------------------------------------------------------------- -- Properties @@ -291,9 +310,6 @@ callGetManagedObjects cl bus path = do return M.empty Right v -> return $ fromMaybe M.empty $ fromSingletonVariant v --- either (const M.empty) (fromMaybe M.empty . fromSingletonVariant) --- <$> - addInterfaceChangedListener :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c) => BusName @@ -303,8 +319,22 @@ addInterfaceChangedListener -> 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 + res <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop) + case res of + Nothing -> do + logError $ + "could not add listener for property" + <> prop_ + <> " at path " + <> path_ + <> " on bus " + <> bus_ + return Nothing + Just rule -> Just <$> addMatchCallback rule sc cl + where + bus_ = "'" <> displayBusName bus <> "'" + path_ = "'" <> displayObjectPath path <> "'" + prop_ = "'" <> displayMemberName prop <> "'" addInterfaceAddedListener :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c) @@ -345,4 +375,22 @@ exportPair path toIface cl = (up, down) down = do logInfo $ "removing interface: " <> path_ liftIO $ unexport cl_ path - path_ = Utf8Builder $ encodeUtf8Builder $ T.pack $ formatObjectPath path + path_ = displayObjectPath path + +-------------------------------------------------------------------------------- +-- logging helpers + +displayBusName :: BusName -> Utf8Builder +displayBusName = displayBytesUtf8 . BC.pack . formatBusName + +displayObjectPath :: ObjectPath -> Utf8Builder +displayObjectPath = displayBytesUtf8 . BC.pack . formatObjectPath + +displayMemberName :: MemberName -> Utf8Builder +displayMemberName = displayBytesUtf8 . BC.pack . formatMemberName + +displayInterfaceName :: InterfaceName -> Utf8Builder +displayInterfaceName = displayBytesUtf8 . BC.pack . formatInterfaceName + +displayWrapQuote :: Utf8Builder -> Utf8Builder +displayWrapQuote x = "'" <> x <> "'"