ENH log errors when adding signal matchers

This commit is contained in:
Nathan Dwarshuis 2023-01-01 20:37:06 -05:00
parent 6848fbe01f
commit 04a7a70747
1 changed files with 57 additions and 9 deletions

View File

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