diff --git a/bin/xmobar.hs b/bin/xmobar.hs index 0f3d0af..2af40c9 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -11,7 +11,7 @@ module Main (main) where -- * Theme integration with xmonad (shared module imported below) -- * A custom Locks plugin from my own forked repo -import Control.Monad (unless) +import Control.Monad import Data.Either import Data.List @@ -42,7 +42,8 @@ import XMonad.Hooks.DynamicLog import XMonad.Internal.Command.Power (hasBattery) import XMonad.Internal.DBus.Brightness.ClevoKeyboard import XMonad.Internal.DBus.Brightness.IntelBacklight -import XMonad.Internal.DBus.Control +import XMonad.Internal.DBus.Common +-- import XMonad.Internal.DBus.Control import XMonad.Internal.DBus.Screensaver (ssSignalDep) import XMonad.Internal.Dependency import XMonad.Internal.Shell @@ -162,7 +163,7 @@ btCmd :: CmdSpec btCmd = CmdSpec { csAlias = btAlias , csRunnable = Run - $ Bluetooth ("\xf293", T.fgColor, T.backdropFgColor) 5 + $ Bluetooth ("\xf293", T.fgColor, T.backdropFgColor) } alsaCmd :: CmdSpec diff --git a/lib/XMonad/Internal/DBus/Common.hs b/lib/XMonad/Internal/DBus/Common.hs index a4d5666..1e006cb 100644 --- a/lib/XMonad/Internal/DBus/Common.hs +++ b/lib/XMonad/Internal/DBus/Common.hs @@ -6,12 +6,19 @@ module XMonad.Internal.DBus.Common , getDBusClient , withDBusClient , withDBusClient_ + , withDBusClientConnection_ + , matchProperty , xmonadBusName + , matchPropertyChanged + , SignalMatch(..) + , callPropertyGet ) where import Control.Exception import Control.Monad +import qualified Data.Map.Strict as M + import DBus import DBus.Client @@ -41,3 +48,47 @@ withDBusClient_ sys f = do client <- getDBusClient sys mapM_ f client mapM_ disconnect client + +withDBusClientConnection_ :: Bool -> (Client -> IO ()) -> IO () +withDBusClientConnection_ sys f = do + client <- getDBusClient sys + mapM_ f client + +propertyInterface :: InterfaceName +propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties" + +propertySignal :: MemberName +propertySignal = memberName_ "PropertiesChanged" + +matchProperty :: ObjectPath -> MatchRule +matchProperty p = matchAny + -- NOTE: the sender for signals is usually the unique name (eg :X.Y) not the + -- requested name (eg "org.something.understandable"). If sender is included + -- here, likely nothing will match. Solution is to somehow get the unique + -- name, which I could do, but probably won't + { matchPath = Just p + , matchInterface = Just propertyInterface + , matchMember = Just propertySignal + } + +data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show) + +matchPropertyChanged :: InterfaceName -> String -> (Variant -> Maybe a) + -> [Variant] -> SignalMatch a +matchPropertyChanged iface property f [i, body, _] = + let i' = (fromVariant i :: Maybe String) + b = toMap body in + case (i', b) of + (Just i'', Just b') -> if i'' == formatInterfaceName iface then + maybe NoMatch Match $ f =<< M.lookup property b' + else NoMatch + _ -> Failure + where + toMap v = fromVariant v :: Maybe (M.Map String Variant) +matchPropertyChanged _ _ _ _ = Failure + +callPropertyGet :: BusName -> ObjectPath -> InterfaceName -> String -> Client + -> IO [Variant] +callPropertyGet bus path iface property client = either (const []) (:[]) + <$> getProperty client (methodCall path iface $ memberName_ property) + { methodCallDestination = Just bus } diff --git a/lib/Xmobar/Plugins/Bluetooth.hs b/lib/Xmobar/Plugins/Bluetooth.hs index 308a3ee..d9c54b5 100644 --- a/lib/Xmobar/Plugins/Bluetooth.hs +++ b/lib/Xmobar/Plugins/Bluetooth.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -------------------------------------------------------------------------------- -- | Bluetooth plugin -- @@ -12,25 +9,21 @@ module Xmobar.Plugins.Bluetooth , btDep ) where +import Data.Maybe import DBus import DBus.Client -import XMonad.Hooks.DynamicLog (xmobarColor) +import XMonad.Hooks.DynamicLog (xmobarColor) +import XMonad.Internal.DBus.Common import XMonad.Internal.Dependency import Xmobar -data Bluetooth = Bluetooth (String, String, String) Int - deriving (Read, Show) +newtype Bluetooth = Bluetooth (String, String, String) deriving (Read, Show) --- TODO match property signal here -callGetPowered :: Client -> IO (Maybe Variant) -callGetPowered client = either (const Nothing) Just - <$> getProperty client (methodCall btPath btInterface $ memberName_ btPowered) - { methodCallDestination = Just btBus } btInterface :: InterfaceName -btInterface = "org.bluez.Adapter1" +btInterface = interfaceName_ "org.bluez.Adapter1" -- weird that this is a string when introspecting but a member name when calling -- a method, not sure if it is supposed to work like that @@ -38,11 +31,11 @@ btPowered :: String btPowered = "Powered" btBus :: BusName -btBus = "org.bluez" +btBus = busName_ "org.bluez" -- TODO this feels like something that shouldn't be hardcoded btPath :: ObjectPath -btPath = "/org/bluez/hci0" +btPath = objectPath_ "/org/bluez/hci0" btAlias :: String btAlias = "bluetooth" @@ -50,15 +43,21 @@ btAlias = "bluetooth" btDep :: DBusDep btDep = Endpoint btBus btPath btInterface $ Property_ btPowered +matchPowered :: [Variant] -> SignalMatch Bool +matchPowered = matchPropertyChanged btInterface btPowered fromVariant + +callGetPowered :: Client -> IO [Variant] +callGetPowered = callPropertyGet btBus btPath btInterface btPowered + instance Exec Bluetooth where - alias (Bluetooth _ _) = btAlias - rate (Bluetooth _ r) = r - run (Bluetooth (text, colorOn, colorOff) _) = do - client <- connectSystem - reply <- callGetPowered client - disconnect client - return $ fmtState $ fromVariant =<< reply + alias (Bluetooth _) = btAlias + start (Bluetooth (text, colorOn, colorOff)) cb = do + withDBusClientConnection_ True $ \c -> do + reply <- callGetPowered c + cb $ maybe "N/A" chooseColor $ fromVariant =<< listToMaybe reply + addMatchCallback (matchProperty btPath) (procMatch cb . matchPowered) c where - fmtState = \case - Just s -> xmobarColor (if s then colorOn else colorOff) "" text - Nothing -> "N/A" + procMatch f (Match on) = f $ chooseColor on + procMatch f Failure = f "N/A" + procMatch _ NoMatch = return () + chooseColor state = xmobarColor (if state then colorOn else colorOff) "" text