diff --git a/lib/Data/Internal/DBus.hs b/lib/Data/Internal/DBus.hs index 409716e..69651a1 100644 --- a/lib/Data/Internal/DBus.hs +++ b/lib/Data/Internal/DBus.hs @@ -28,6 +28,11 @@ module Data.Internal.DBus , fromSingletonVariant , bodyToMaybe , exportPair + , displayBusName + , displayObjectPath + , displayMemberName + , displayInterfaceName + , displayWrapQuote ) where @@ -200,8 +205,7 @@ matchSignalFull client b p i m = do 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 + logError msg return Nothing where bus_ = displayWrapQuote $ displayBusName b @@ -209,11 +213,11 @@ matchSignalFull client b p i m = do 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_] + intersperse ", " $ + mapMaybe (\(k, v) -> fmap ((k <> "=") <>) v) $ + zip ["interface", "path", "member"] [iface_, path_, mem_] + stem = "could not get match rule for bus " <> bus_ + msg = if null match then stem else stem <> " where " <> mconcat match -------------------------------------------------------------------------------- -- Properties diff --git a/lib/Xmobar/Plugins/Bluetooth.hs b/lib/Xmobar/Plugins/Bluetooth.hs index 58536c0..e5acde8 100644 --- a/lib/Xmobar/Plugins/Bluetooth.hs +++ b/lib/Xmobar/Plugins/Bluetooth.hs @@ -81,7 +81,6 @@ startAdapter is cs cb cl = do forM_ (findAdapter ot) $ \adapter -> do -- set up adapter initAdapter state adapter cl - -- TODO this step could fail; at least warn the user... void $ addAdaptorListener state dpy adapter cl -- set up devices on the adapter (and listeners for adding/removing devices) let devices = findDevices adapter ot @@ -223,6 +222,8 @@ initAdapter -> m () initAdapter state adapter client = do reply <- callGetPowered adapter client + -- TODO this could fail if the variant is something weird; the only + -- indication I will get is "NA" putPowered state $ fromSingletonVariant reply matchBTProperty @@ -232,6 +233,31 @@ matchBTProperty -> m (Maybe MatchRule) matchBTProperty sys p = matchPropertyFull sys btBus (Just p) +withBTPropertyRule + :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, IsVariant a) + => SysClient + -> ObjectPath + -> (Maybe a -> m ()) + -> InterfaceName + -> T.Text + -> m (Maybe SignalHandler) +withBTPropertyRule cl path update iface prop = do + res <- matchBTProperty cl path + case res of + Just rule -> Just <$> addMatchCallback rule (signalToUpdate . matchConnected) cl + Nothing -> do + logError $ + "could not add listener for prop " + <> prop_ + <> " on path " + <> path_ + return Nothing + where + path_ = displayObjectPath path + prop_ = Utf8Builder $ encodeUtf8Builder prop + signalToUpdate = withSignalMatch update + matchConnected = matchPropertyChanged iface prop + addAdaptorListener :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) => MutableBtState @@ -240,10 +266,9 @@ addAdaptorListener -> SysClient -> m (Maybe SignalHandler) addAdaptorListener state dpy adaptor sys = do - rule <- matchBTProperty sys adaptor - forM rule $ \r -> addMatchCallback r (procMatch . matchPowered) sys + withBTPropertyRule sys adaptor procMatch adapterInterface adaptorPowered where - procMatch = withSignalMatch $ \b -> putPowered state b >> dpy + procMatch b = putPowered state b >> dpy callGetPowered :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) @@ -255,9 +280,6 @@ callGetPowered adapter = memberName_ $ T.unpack adaptorPowered -matchPowered :: [Variant] -> SignalMatch Bool -matchPowered = matchPropertyChanged adapterInterface adaptorPowered - putPowered :: MonadUnliftIO m => MutableBtState -> Maybe Bool -> m () putPowered m ds = modifyMVar_ m (\s -> return s {btPowered = ds}) @@ -309,13 +331,9 @@ addDeviceListener -> SysClient -> m (Maybe SignalHandler) addDeviceListener state dpy device sys = do - rule <- matchBTProperty sys device - forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) sys + withBTPropertyRule sys device procMatch devInterface devConnected where - procMatch = withSignalMatch $ \c -> updateDevice state device c >> dpy - -matchConnected :: [Variant] -> SignalMatch Bool -matchConnected = matchPropertyChanged devInterface devConnected + procMatch c = updateDevice state device c >> dpy callGetConnected :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)