ENH log errors when adding signal matchers
This commit is contained in:
parent
6848fbe01f
commit
04a7a70747
|
@ -35,6 +35,7 @@ import DBus
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
import qualified Data.ByteString.Char8 as BC
|
import qualified Data.ByteString.Char8 as BC
|
||||||
import RIO
|
import RIO
|
||||||
|
import RIO.List
|
||||||
import qualified RIO.Map as M
|
import qualified RIO.Map as M
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
|
@ -92,7 +93,7 @@ getDBusClient' sys = do
|
||||||
res <- try $ liftIO $ if sys then connectSystem else connectSession
|
res <- try $ liftIO $ if sys then connectSystem else connectSession
|
||||||
case res of
|
case res of
|
||||||
Left e -> do
|
Left e -> do
|
||||||
logInfo $ Utf8Builder $ encodeUtf8Builder $ T.pack $ clientErrorMessage e
|
logInfo $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
|
||||||
return Nothing
|
return Nothing
|
||||||
Right c -> return $ Just c
|
Right c -> return $ Just c
|
||||||
|
|
||||||
|
@ -151,6 +152,7 @@ callGetNameOwner cl name = do
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Variant parsing
|
-- Variant parsing
|
||||||
|
|
||||||
|
-- TODO log failures here?
|
||||||
fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a
|
fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a
|
||||||
fromSingletonVariant = fromVariant <=< listToMaybe
|
fromSingletonVariant = fromVariant <=< listToMaybe
|
||||||
|
|
||||||
|
@ -193,8 +195,25 @@ matchSignalFull
|
||||||
-> Maybe InterfaceName
|
-> Maybe InterfaceName
|
||||||
-> Maybe MemberName
|
-> Maybe MemberName
|
||||||
-> m (Maybe MatchRule)
|
-> m (Maybe MatchRule)
|
||||||
matchSignalFull client b p i m =
|
matchSignalFull client b p i m = do
|
||||||
fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b
|
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
|
-- Properties
|
||||||
|
@ -291,9 +310,6 @@ callGetManagedObjects cl bus path = do
|
||||||
return M.empty
|
return M.empty
|
||||||
Right v -> return $ fromMaybe M.empty $ fromSingletonVariant v
|
Right v -> return $ fromMaybe M.empty $ fromSingletonVariant v
|
||||||
|
|
||||||
-- either (const M.empty) (fromMaybe M.empty . fromSingletonVariant)
|
|
||||||
-- <$>
|
|
||||||
|
|
||||||
addInterfaceChangedListener
|
addInterfaceChangedListener
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
|
||||||
=> BusName
|
=> BusName
|
||||||
|
@ -303,8 +319,22 @@ addInterfaceChangedListener
|
||||||
-> c
|
-> c
|
||||||
-> m (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)
|
res <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop)
|
||||||
forM rule $ \r -> addMatchCallback r sc cl
|
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
|
addInterfaceAddedListener
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
|
||||||
|
@ -345,4 +375,22 @@ exportPair path toIface cl = (up, down)
|
||||||
down = do
|
down = do
|
||||||
logInfo $ "removing interface: " <> path_
|
logInfo $ "removing interface: " <> path_
|
||||||
liftIO $ unexport cl_ 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 <> "'"
|
||||||
|
|
Loading…
Reference in New Issue