diff --git a/bin/xmobar.hs b/bin/xmobar.hs index f01399b..8790fce 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -123,7 +123,7 @@ config confDir = defaultConfig , Run $ Screensaver ("\xf254", T.fgColor, T.backdropFgColor) - , Run $ Bluetooth ("BT", T.fgColor, T.backdropFgColor) + , Run $ Bluetooth ("\xf293", T.fgColor, T.backdropFgColor) , Run UnsafeStdinReader ] diff --git a/lib/Xmobar/Plugins/Bluetooth.hs b/lib/Xmobar/Plugins/Bluetooth.hs index 838c6f4..9184d2a 100644 --- a/lib/Xmobar/Plugins/Bluetooth.hs +++ b/lib/Xmobar/Plugins/Bluetooth.hs @@ -6,43 +6,65 @@ module Xmobar.Plugins.Bluetooth where import Control.Concurrent import Control.Monad -import Data.List (find) -import Data.Maybe (mapMaybe) +import qualified Data.Map.Lazy as M +import Data.Maybe import DBus import DBus.Client +import DBus.Internal.Types import Xmobar newtype Bluetooth = Bluetooth (String, String, String) deriving (Read, Show) +path :: ObjectPath +path = "/org/bluez/hci0" + +interface :: InterfaceName +interface = "org.freedesktop.DBus.Properties" + rule :: MatchRule rule = matchAny - { matchPath = Just "/org/bluez/hci0" - , matchInterface = Just "org.freedesktop.DBus.Properties" + { matchPath = Just path + , matchInterface = Just interface , matchMember = Just "PropertiesChanged" } +callBT :: Client -> IO (Either MethodError MethodReturn) +callBT client = + call client (methodCall path interface "Get") + { methodCallDestination = Just "org.bluez", methodCallBody = body } + where + body = map toVariant ["org.bluez.Adapter1", "Powered" :: String] + instance Exec Bluetooth where alias (Bluetooth _) = "bluetooth" start (Bluetooth (text, colorOn, colorOff)) cb = do client <- connectSystem - _ <- addMatch client rule $ cb . fmtState . stateFromSignal - -- TODO initialize here - -- cb . formatBrightness =<< callGetBrightness + _ <- addMatch client rule $ + cb . fmtState . lookupState . getProps . signalBody + reply <- callBT client + -- TODO handle errors? + case reply of + Right ret -> cb + $ fmtState + $ fromVariant + =<< fromVariant + =<< listToMaybe (methodReturnBody ret) + Left _ -> return () forever (threadDelay 5000) where - -- TODO this is total utter garbage...but it works... - stateFromSignal sig = join - $ fmap (fromVariant :: (Variant -> Maybe Bool)) - $ join - $ fmap (fromVariant :: (Variant -> Maybe Variant)) - $ fmap snd - $ find (\(k, _) -> (fromVariant k :: Maybe String) == Just "Powered") - $ concatMap dictionaryItems - $ mapMaybe fromVariant - $ filter (\v -> variantType v == TypeDictionary TypeString TypeVariant) - $ signalBody sig + -- Assume that the data in the PropertiesChanged signal has the form + -- [something, Map, something] where the Map in the middle has the + -- "Powered" text key that we care about (among other things that change + -- when the bluetooth interface is powered on) + getProps = \case + [_, Variant (ValueMap TypeString TypeVariant m), _] -> Just m + _ -> Nothing + lookupState m = fromVariant + =<< fromValue + =<< M.lookup (AtomText "Powered") + =<< m fmtState = \case Just s -> wrapColor text $ if s then colorOn else colorOff Nothing -> "N/A" diff --git a/my-xmonad.cabal b/my-xmonad.cabal index 896de17..8c26e21 100644 --- a/my-xmonad.cabal +++ b/my-xmonad.cabal @@ -25,6 +25,7 @@ library , fdo-notify , dbus >= 1.2.7 , text >= 1.2.3.1 + , containers >= 0.6.0.1 , xmobar ghc-options: -Wall -Werror -fno-warn-missing-signatures default-language: Haskell2010