From 8282cf05cc52c862bf9c7f2c687ab85304486703 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Fri, 26 Nov 2021 23:35:03 -0500 Subject: [PATCH] ENH make bluetooth module display connection status --- bin/xmobar.hs | 18 +- lib/XMonad/Internal/DBus/Brightness/Common.hs | 4 +- lib/XMonad/Internal/DBus/Common.hs | 41 +-- lib/XMonad/Internal/DBus/Screensaver.hs | 3 +- lib/XMonad/Internal/Dependency.hs | 63 +++- lib/Xmobar/Plugins/BacklightCommon.hs | 3 +- lib/Xmobar/Plugins/Bluetooth.hs | 280 ++++++++++++++++-- lib/Xmobar/Plugins/Common.hs | 27 +- lib/Xmobar/Plugins/Device.hs | 6 +- lib/Xmobar/Plugins/Screensaver.hs | 3 +- lib/Xmobar/Plugins/VPN.hs | 6 +- my-xmonad.cabal | 1 + 12 files changed, 376 insertions(+), 79 deletions(-) diff --git a/bin/xmobar.hs b/bin/xmobar.hs index 4a8cf32..94e819c 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -63,9 +63,9 @@ main = do config :: BarRegions -> String -> Config config br confDir = defaultConfig { font = barFont - , additionalFonts = [iconFont, iconFontLarge, iconFontXLarge] + , additionalFonts = [iconFont, iconFontLarge, iconFontXLarge, iconFontXXLarge] , textOffset = 16 - , textOffsets = [16, 17, 18] + , textOffsets = [16, 17, 17, 18] , bgColor = T.bgColor , fgColor = T.fgColor , position = BottomSize C 100 24 @@ -161,7 +161,8 @@ btCmd :: CmdSpec btCmd = CmdSpec { csAlias = btAlias , csRunnable = Run - $ Bluetooth ("\xf293", T.fgColor, T.backdropFgColor) + -- $ Bluetooth ("\xf293", T.fgColor, T.backdropFgColor) + $ Bluetooth ("\xf5b0", "\xf5ae") (T.fgColor, T.backdropFgColor) } alsaCmd :: CmdSpec @@ -202,10 +203,10 @@ lockCmd = CmdSpec { csAlias = "locks" , csRunnable = Run $ Locks - [ "-N", "\xf8a5" - , "-n", xmobarColor T.backdropFgColor "" "\xf8a5" + [ "-N", "\xf8a5" + , "-n", xmobarColor T.backdropFgColor "" "\xf8a5" , "-C", "\xf657" - , "-c", xmobarColor T.backdropFgColor "" "\xf657" + , "-c", xmobarColor T.backdropFgColor "" "\xf657" , "-s", "" , "-S", "" , "-d", " " @@ -405,4 +406,7 @@ iconFontLarge :: String iconFontLarge = nerdFont 15 iconFontXLarge :: String -iconFontXLarge = nerdFont 20 +iconFontXLarge = nerdFont 18 + +iconFontXXLarge :: String +iconFontXXLarge = nerdFont 20 diff --git a/lib/XMonad/Internal/DBus/Brightness/Common.hs b/lib/XMonad/Internal/DBus/Brightness/Common.hs index 8fe815c..7242830 100644 --- a/lib/XMonad/Internal/DBus/Brightness/Common.hs +++ b/lib/XMonad/Internal/DBus/Brightness/Common.hs @@ -11,7 +11,7 @@ module XMonad.Internal.DBus.Brightness.Common , signalDep ) where --- import Control.Monad (void) +import Control.Monad (void) import Data.Int (Int32) @@ -73,7 +73,7 @@ signalDep BrightnessConfig { bcPath = p, bcInterface = i } = matchSignal :: Num c => BrightnessConfig a b -> (Maybe c -> IO ()) -> Client -> IO () matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = - addMatchCallback brMatcher (cb . bodyGetBrightness) + void . addMatchCallback brMatcher (cb . bodyGetBrightness) where brMatcher = matchAny { matchPath = Just p diff --git a/lib/XMonad/Internal/DBus/Common.hs b/lib/XMonad/Internal/DBus/Common.hs index 1e006cb..89ef398 100644 --- a/lib/XMonad/Internal/DBus/Common.hs +++ b/lib/XMonad/Internal/DBus/Common.hs @@ -6,16 +6,17 @@ module XMonad.Internal.DBus.Common , getDBusClient , withDBusClient , withDBusClient_ - , withDBusClientConnection_ , matchProperty + , matchProperty' , xmonadBusName , matchPropertyChanged , SignalMatch(..) + , SignalCallback + , withSignalMatch , callPropertyGet ) where import Control.Exception -import Control.Monad import qualified Data.Map.Strict as M @@ -25,9 +26,11 @@ import DBus.Client xmonadBusName :: BusName xmonadBusName = busName_ "org.xmonad" +type SignalCallback = [Variant] -> IO () + -- | Bind a callback to a signal match rule -addMatchCallback :: MatchRule -> ([Variant] -> IO ()) -> Client -> IO () -addMatchCallback rule cb client = void $ addMatch client rule $ cb . signalBody +addMatchCallback :: MatchRule -> SignalCallback -> Client -> IO SignalHandler +addMatchCallback rule cb client = addMatch client rule $ cb . signalBody getDBusClient :: Bool -> IO (Maybe Client) getDBusClient sys = do @@ -49,46 +52,50 @@ withDBusClient_ sys f = do 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 +matchProperty' :: Maybe 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 + { matchPath = p , matchInterface = Just propertyInterface , matchMember = Just propertySignal } +matchProperty :: ObjectPath -> MatchRule +matchProperty = matchProperty' . Just + 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, _] = +withSignalMatch :: (Maybe a -> IO ()) -> SignalMatch a -> IO () +withSignalMatch f (Match x) = f (Just x) +withSignalMatch f Failure = f Nothing +withSignalMatch _ NoMatch = return () + +matchPropertyChanged :: IsVariant a => InterfaceName -> String -> [Variant] + -> SignalMatch a +matchPropertyChanged iface property [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' + maybe NoMatch Match $ fromVariant =<< M.lookup property b' else NoMatch _ -> Failure where toMap v = fromVariant v :: Maybe (M.Map String Variant) -matchPropertyChanged _ _ _ _ = Failure +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/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index 353788e..687a5b8 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/lib/XMonad/Internal/DBus/Screensaver.hs @@ -130,7 +130,8 @@ callQuery client = do return $ either (const Nothing) bodyGetCurrentState reply matchSignal :: (Maybe SSState -> IO ()) -> Client -> IO () -matchSignal cb = addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState +matchSignal cb = + fmap void . addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState ssSignalDep :: DBusDep ssSignalDep = Endpoint xmonadBusName ssPath interface $ Signal_ memState diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index 5671375..d3c9a0d 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/lib/XMonad/Internal/Dependency.hs @@ -36,24 +36,36 @@ module XMonad.Internal.Dependency , executeFeatureWith_ , callMethod , callMethod' + , callGetManagedObjects + , ObjectTree + , getManagedObjects + , omInterface + , addInterfaceAddedListener + , addInterfaceRemovedListener ) where import Control.Monad.IO.Class import Control.Monad.Identity -import Data.Bifunctor (bimap) -import Data.List (find) -import Data.Maybe (catMaybes, fromMaybe, listToMaybe) +import Data.Bifunctor (bimap) +import Data.List (find) +import qualified Data.Map as M +import Data.Maybe (catMaybes, fromMaybe, listToMaybe) import DBus import DBus.Client -import qualified DBus.Introspection as I +import qualified DBus.Introspection as I -import System.Directory (findExecutable, readable, writable) +import System.Directory + ( findExecutable + , readable + , writable + ) import System.Environment import System.Exit -import XMonad.Core (X, io) +import XMonad.Core (X, io) +import XMonad.Internal.DBus.Common import XMonad.Internal.IO import XMonad.Internal.Process import XMonad.Internal.Shell @@ -376,3 +388,42 @@ dbusDepSatisfied client (Endpoint busname objpath iface mem) = do , "on bus" , formatBusName busname ] + +-------------------------------------------------------------------------------- +-- | Object Manager + +type ObjectTree = M.Map ObjectPath (M.Map String (M.Map String Variant)) + +omInterface :: InterfaceName +omInterface = interfaceName_ "org.freedesktop.DBus.ObjectManager" + +getManagedObjects :: MemberName +getManagedObjects = memberName_ "GetManagedObjects" + +callGetManagedObjects :: Client -> BusName -> ObjectPath -> IO ObjectTree +callGetManagedObjects client bus path = + either (const M.empty) (fromMaybe M.empty . (fromVariant <=< listToMaybe)) + <$> callMethod client bus path omInterface getManagedObjects + +omInterfacesAdded :: MemberName +omInterfacesAdded = memberName_ "InterfacesAdded" + +omInterfacesRemoved :: MemberName +omInterfacesRemoved = memberName_ "InterfacesRemoved" + +-- TODO add busname back to this (use NameGetOwner on org.freedesktop.DBus) +addInterfaceChangedListener :: MemberName -> ObjectPath -> SignalCallback + -> Client -> IO () +addInterfaceChangedListener prop path = fmap void . addMatchCallback rule + where + rule = matchAny + { matchPath = Just path + , matchInterface = Just omInterface + , matchMember = Just prop + } + +addInterfaceAddedListener :: ObjectPath -> SignalCallback -> Client -> IO () +addInterfaceAddedListener = addInterfaceChangedListener omInterfacesAdded + +addInterfaceRemovedListener :: ObjectPath -> SignalCallback -> Client -> IO () +addInterfaceRemovedListener = addInterfaceChangedListener omInterfacesRemoved diff --git a/lib/Xmobar/Plugins/BacklightCommon.hs b/lib/Xmobar/Plugins/BacklightCommon.hs index 3306d9c..822eda5 100644 --- a/lib/Xmobar/Plugins/BacklightCommon.hs +++ b/lib/Xmobar/Plugins/BacklightCommon.hs @@ -8,13 +8,12 @@ module Xmobar.Plugins.BacklightCommon (startBacklight) where import DBus.Client -import XMonad.Internal.DBus.Common import Xmobar.Plugins.Common startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> Client -> IO ()) -> (Client -> IO (Maybe a)) -> String -> (String -> IO ()) -> IO () startBacklight matchSignal callGetBrightness icon cb = do - withDBusClientConnection_ False $ \c -> do + withDBusClientConnection False cb $ \c -> do matchSignal (cb . formatBrightness) c cb . formatBrightness =<< callGetBrightness c where diff --git a/lib/Xmobar/Plugins/Bluetooth.hs b/lib/Xmobar/Plugins/Bluetooth.hs index cb0b2a9..ce7d95e 100644 --- a/lib/Xmobar/Plugins/Bluetooth.hs +++ b/lib/Xmobar/Plugins/Bluetooth.hs @@ -2,6 +2,33 @@ -- | Bluetooth plugin -- -- Use the bluez interface on DBus to check status +-- +-- org.bluez dynamically updates its DBus interfaces using the standard Object +-- Manager. The adapter is located at path "/org/bluez/hci" where X is +-- usually 0, and each device is "/org/bluez/hci/". +-- +-- This plugin will reflect if the adapter is powered and if any device is +-- connected to it. The rough outline for this procedure: +-- 1) get the adapter from the object manager +-- 2) get all devices associated with the adapter using the object interface +-- 3) determine if the adapter is powered +-- 4) determine if any devices are connected +-- 5) format the icon; powered vs not powered controls the color and connected +-- vs not connected controls the icon (connected bluetooth symbol has two +-- dots flanking it) +-- +-- Step 3 can be accomplished using the "org.bluez.Adapter1" interface and +-- querying the "Powered" property. Step 4 can be done using the +-- "org.bluez.Device1" interface and the "Connected" property for each device +-- path. Since these are properties, we can asynchronously read changes to them +-- via the "PropertiesChanged" signal. +-- +-- If any devices are added/removed, steps 2-4 will need to be redone and any +-- listeners will need to be updated. (TODO not sure which signals to use in +-- determining if a device is added) +-- +-- TODO also not sure if I need to care about multiple adapters and/or the +-- adapter changing. module Xmobar.Plugins.Bluetooth ( Bluetooth(..) @@ -9,6 +36,14 @@ module Xmobar.Plugins.Bluetooth , btDep ) where +import Control.Concurrent.MVar +import Control.Monad + +import Data.List +import Data.List.Split +import qualified Data.Map as M +import Data.Maybe + import DBus import DBus.Client @@ -17,42 +52,225 @@ import XMonad.Internal.Dependency import Xmobar import Xmobar.Plugins.Common -newtype Bluetooth = Bluetooth (String, String, String) deriving (Read, Show) - - -btInterface :: InterfaceName -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 -btPowered :: String -btPowered = "Powered" - -btBus :: BusName -btBus = busName_ "org.bluez" - --- TODO this feels like something that shouldn't be hardcoded -btPath :: ObjectPath -btPath = objectPath_ "/org/bluez/hci0" - btAlias :: String btAlias = "bluetooth" btDep :: DBusDep -btDep = Endpoint btBus btPath btInterface $ Property_ btPowered +btDep = Endpoint btBus btOmPath omInterface $ Method_ getManagedObjects -matchPowered :: [Variant] -> SignalMatch Bool -matchPowered = matchPropertyChanged btInterface btPowered fromVariant - -callGetPowered :: Client -> IO [Variant] -callGetPowered = callPropertyGet btBus btPath btInterface btPowered +data Bluetooth = Bluetooth Icons Colors deriving (Read, Show) instance Exec Bluetooth where - alias (Bluetooth _) = btAlias - start (Bluetooth (text, colorOn, colorOff)) cb = do - withDBusClientConnection_ True $ \c -> do - startListener rule callGetPowered matchPowered chooseColor' cb c - where - rule = matchProperty btPath - chooseColor' = chooseColor text colorOn colorOff + alias (Bluetooth _ _) = btAlias + start (Bluetooth icons colors) cb = + withDBusClientConnection True cb $ startAdapter icons colors cb +startAdapter :: Icons -> Colors -> Callback -> Client -> IO () +startAdapter is cs cb cl = do + ot <- getBtObjectTree cl + state <- newMVar emptyState + let display = displayIcon cb (iconFormatter is cs) state + forM_ (findAdapter ot) $ \adapter -> do + -- set up adapter + initAdapter state adapter cl + addAdaptorListener state display adapter cl + -- set up devices on the adapter (and listeners for adding/removing devices) + let devices = findDevices adapter ot + addDeviceAddedListener state display adapter cl + addDeviceRemovedListener state display adapter cl + forM_ devices $ \d -> addAndInitDevice state display d cl + -- after setting things up, show the icon based on the initialized state + display + +-------------------------------------------------------------------------------- +-- | Icon Display +-- +-- Color corresponds to the adaptor powered state, and the icon corresponds to +-- if it is paired or not. If the adaptor state is undefined, display "N/A" + +type IconFormatter = (Maybe Bool -> Bool -> String) + +type Icons = (String, String) + +type Colors = (String, String) + +displayIcon :: Callback -> IconFormatter -> MutableBtState -> IO () +displayIcon callback formatter = + callback . uncurry formatter <=< readState + +-- TODO maybe I want this to fail when any of the device statuses are Nothing +iconFormatter :: Icons -> Colors -> IconFormatter +iconFormatter (iconConn, iconDisc) (colorOn, colorOff) powered connected = + maybe na (chooseColor icon colorOn colorOff) powered + where + icon = if connected then iconConn else iconDisc + +-------------------------------------------------------------------------------- +-- | Connection State +-- +-- The signal handlers all run on separate threads, yet the icon depends on +-- the state reflected by all these signals. The best (only?) way to do this is +-- is to track the shared state of the bluetooth adaptor and its devices using +-- an MVar. + +data BTDevice = BTDevice + { btDevConnected :: Maybe Bool + , btDevSigHandler :: SignalHandler + } + +type ConnectedDevices = M.Map ObjectPath BTDevice + +data BtState = BtState + { btDevices :: ConnectedDevices + , btPowered :: Maybe Bool + } + +type MutableBtState = MVar BtState + +emptyState :: BtState +emptyState = BtState + { btDevices = M.empty + , btPowered = Nothing + } + +readState :: MutableBtState -> IO (Maybe Bool, Bool) +readState state = do + p <- readPowered state + c <- readDevices state + return (p, anyDevicesConnected c) + +-------------------------------------------------------------------------------- +-- | Object manager + +findAdapter :: ObjectTree -> Maybe ObjectPath +findAdapter = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys + +findDevices :: ObjectPath -> ObjectTree -> [ObjectPath] +findDevices adapter = filter (adaptorHasDevice adapter) . M.keys + +adaptorHasDevice :: ObjectPath -> ObjectPath -> Bool +adaptorHasDevice adaptor device = case splitPath device of + [org, bluez, hciX, _] -> splitPath adaptor == [org, bluez, hciX] + _ -> False + +splitPath :: ObjectPath -> [String] +splitPath = splitOn "/" . dropWhile (=='/') . formatObjectPath + +getBtObjectTree :: Client -> IO ObjectTree +getBtObjectTree client = callGetManagedObjects client btBus btOmPath + +btBus :: BusName +btBus = busName_ "org.bluez" + +btOmPath :: ObjectPath +btOmPath = objectPath_ "/" + +addDeviceAddedListener :: MutableBtState -> IO () -> ObjectPath -> Client -> IO () +addDeviceAddedListener state display adapter client = + addInterfaceAddedListener btOmPath addDevice client + where + addDevice = pathCallback adapter display $ \d -> + addAndInitDevice state display d client + +addDeviceRemovedListener :: MutableBtState -> IO () -> ObjectPath -> Client -> IO () +addDeviceRemovedListener state display adapter client = + addInterfaceRemovedListener btOmPath remDevice client + where + remDevice = pathCallback adapter display $ \d -> do + old <- removeDevice state d + forM_ old $ removeMatch client . btDevSigHandler + +pathCallback :: ObjectPath -> IO () -> (ObjectPath -> IO ()) -> SignalCallback +pathCallback adapter display f [device, _] = forM_ (fromVariant device) $ \d -> + when (adaptorHasDevice adapter d) $ f d >> display +pathCallback _ _ _ _ = return () + +-------------------------------------------------------------------------------- +-- | Adapter + +initAdapter :: MutableBtState -> ObjectPath -> Client -> IO () +initAdapter state adapter client = do + reply <- callGetPowered adapter client + putPowered state $ fromSingletonVariant reply + +addAdaptorListener :: MutableBtState -> IO () -> ObjectPath -> Client -> IO () +addAdaptorListener state display adaptor = + void . addMatchCallback rule (procMatch . matchPowered) + where + rule = matchProperty adaptor + procMatch = withSignalMatch $ \b -> putPowered state b >> display + +callGetPowered :: ObjectPath -> Client -> IO [Variant] +callGetPowered adapter = + callPropertyGet btBus adapter adapterInterface adaptorPowered + +matchPowered :: [Variant] -> SignalMatch Bool +matchPowered = matchPropertyChanged adapterInterface adaptorPowered + +putPowered :: MutableBtState -> Maybe Bool -> IO () +putPowered m ds = modifyMVar_ m (\s -> return s { btPowered = ds }) + +readPowered :: MutableBtState -> IO (Maybe Bool) +readPowered = fmap btPowered . readMVar + +adapterInterface :: InterfaceName +adapterInterface = interfaceName_ "org.bluez.Adapter1" + +adaptorPowered :: String +adaptorPowered = "Powered" + +-------------------------------------------------------------------------------- +-- | Devices + +addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> Client -> IO () +addAndInitDevice state display device client = do + sh <- addDeviceListener state display device client + initDevice state sh device client + +initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> Client -> IO () +initDevice state sh device client = do + reply <- callGetConnected device client + void $ insertDevice state device $ + BTDevice { btDevConnected = fromVariant =<< listToMaybe reply + , btDevSigHandler = sh + } + +addDeviceListener :: MutableBtState -> IO () -> ObjectPath -> Client -> IO SignalHandler +addDeviceListener state display device = + addMatchCallback rule (procMatch . matchConnected) + where + rule = matchProperty device + procMatch = withSignalMatch $ \c -> updateDevice state device c >> display + +matchConnected :: [Variant] -> SignalMatch Bool +matchConnected = matchPropertyChanged devInterface devConnected + +callGetConnected :: ObjectPath -> Client -> IO [Variant] +callGetConnected p = callPropertyGet btBus p devInterface devConnected + +insertDevice :: MutableBtState -> ObjectPath -> BTDevice -> IO Bool +insertDevice m device dev = modifyMVar m $ \s -> do + let new = M.insert device dev $ btDevices s + return (s { btDevices = new }, anyDevicesConnected new) + +updateDevice :: MutableBtState -> ObjectPath -> Maybe Bool -> IO Bool +updateDevice m device status = modifyMVar m $ \s -> do + let new = M.update (\d -> Just d { btDevConnected = status }) device $ btDevices s + return (s { btDevices = new }, anyDevicesConnected new) + +anyDevicesConnected :: ConnectedDevices -> Bool +anyDevicesConnected = or . mapMaybe btDevConnected . M.elems + +removeDevice :: MutableBtState -> ObjectPath -> IO (Maybe BTDevice) +removeDevice m device = modifyMVar m $ \s -> do + let devs = btDevices s + return (s { btDevices = M.delete device devs }, M.lookup device devs) + +readDevices :: MutableBtState -> IO ConnectedDevices +readDevices = fmap btDevices . readMVar + +devInterface :: InterfaceName +devInterface = interfaceName_ "org.bluez.Device1" + +devConnected :: String +devConnected = "Connected" diff --git a/lib/Xmobar/Plugins/Common.hs b/lib/Xmobar/Plugins/Common.hs index 7272f4d..c3f90d0 100644 --- a/lib/Xmobar/Plugins/Common.hs +++ b/lib/Xmobar/Plugins/Common.hs @@ -2,10 +2,16 @@ module Xmobar.Plugins.Common ( chooseColor , startListener + , procSignalMatch , na + , fromSingletonVariant + , withDBusClientConnection + , Callback ) where +import Control.Monad + import DBus import DBus.Client @@ -14,17 +20,22 @@ import Data.Maybe import XMonad.Hooks.DynamicLog (xmobarColor) import XMonad.Internal.DBus.Common +type Callback = String -> IO () + startListener :: IsVariant a => MatchRule -> (Client -> IO [Variant]) - -> ([Variant] -> SignalMatch a) -> (a -> String) -> (String -> IO ()) + -> ([Variant] -> SignalMatch a) -> (a -> IO String) -> Callback -> Client -> IO () startListener rule getProp fromSignal toColor cb client = do reply <- getProp client procMatch $ maybe Failure Match $ fromVariant =<< listToMaybe reply - addMatchCallback rule (procMatch . fromSignal) client + void $ addMatchCallback rule (procMatch . fromSignal) client where - procMatch (Match t) = cb $ toColor t - procMatch Failure = cb na - procMatch NoMatch = return () + procMatch = procSignalMatch cb toColor + +procSignalMatch :: (String -> IO ()) -> (a -> IO String) -> SignalMatch a -> IO () +procSignalMatch callback formatter (Match x) = callback =<< formatter x +procSignalMatch callback _ Failure = callback na +procSignalMatch _ _ NoMatch = return () chooseColor :: String -> String -> String -> Bool -> String chooseColor text colorOn colorOff state = @@ -32,3 +43,9 @@ chooseColor text colorOn colorOff state = na :: String na = "N/A" + +fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a +fromSingletonVariant = fromVariant <=< listToMaybe + +withDBusClientConnection :: Bool -> Callback -> (Client -> IO ()) -> IO () +withDBusClientConnection sys cb f = maybe (cb na) f =<< getDBusClient sys diff --git a/lib/Xmobar/Plugins/Device.hs b/lib/Xmobar/Plugins/Device.hs index 7ba7385..39cb86f 100644 --- a/lib/Xmobar/Plugins/Device.hs +++ b/lib/Xmobar/Plugins/Device.hs @@ -58,15 +58,15 @@ getDeviceConnected :: ObjectPath -> Client -> IO [Variant] getDeviceConnected path = callPropertyGet nmBus path nmDeviceInterface devSignal matchStatus :: [Variant] -> SignalMatch Word32 -matchStatus = matchPropertyChanged nmDeviceInterface devSignal fromVariant +matchStatus = matchPropertyChanged nmDeviceInterface devSignal instance Exec Device where alias (Device (iface, _, _, _)) = iface start (Device (iface, text, colorOn, colorOff)) cb = do - withDBusClientConnection_ True $ \c -> do + withDBusClientConnection True cb $ \c -> do path <- getDevice c iface maybe (cb na) (listener c) path where listener client path = startListener (matchProperty path) (getDeviceConnected path) matchStatus chooseColor' cb client - chooseColor' = chooseColor text colorOn colorOff . (> 1) + chooseColor' = return . chooseColor text colorOn colorOff . (> 1) diff --git a/lib/Xmobar/Plugins/Screensaver.hs b/lib/Xmobar/Plugins/Screensaver.hs index cd921d1..d1791f8 100644 --- a/lib/Xmobar/Plugins/Screensaver.hs +++ b/lib/Xmobar/Plugins/Screensaver.hs @@ -11,7 +11,6 @@ module Xmobar.Plugins.Screensaver import Xmobar -import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Screensaver import Xmobar.Plugins.Common @@ -23,7 +22,7 @@ ssAlias = "screensaver" instance Exec Screensaver where alias (Screensaver _) = ssAlias start (Screensaver (text, colorOn, colorOff)) cb = do - withDBusClientConnection_ False $ \c -> do + withDBusClientConnection False cb $ \c -> do matchSignal (cb . fmtState) c cb . fmtState =<< callQuery c where diff --git a/lib/Xmobar/Plugins/VPN.hs b/lib/Xmobar/Plugins/VPN.hs index 494709e..56e6cd2 100644 --- a/lib/Xmobar/Plugins/VPN.hs +++ b/lib/Xmobar/Plugins/VPN.hs @@ -39,10 +39,10 @@ vpnDep = Endpoint vpnBus vpnPath vpnInterface $ Property_ vpnConnType instance Exec VPN where alias (VPN _) = vpnAlias start (VPN (text, colorOn, colorOff)) cb = - withDBusClientConnection_ True + withDBusClientConnection True cb $ startListener rule getProp fromSignal chooseColor' cb where rule = matchProperty vpnPath getProp = callPropertyGet vpnBus vpnPath vpnInterface vpnConnType - fromSignal = matchPropertyChanged vpnInterface vpnConnType fromVariant - chooseColor' = chooseColor text colorOn colorOff . ("vpn" ==) + fromSignal = matchPropertyChanged vpnInterface vpnConnType + chooseColor' = return . chooseColor text colorOn colorOff . ("vpn" ==) diff --git a/my-xmonad.cabal b/my-xmonad.cabal index f66fbe8..4251b95 100644 --- a/my-xmonad.cabal +++ b/my-xmonad.cabal @@ -47,6 +47,7 @@ library , directory >= 1.3.3.0 , process >= 1.6.5.0 , filepath >= 1.4.2.1 + , split >= 0.2.3.4 , xmobar , xmonad-extras >= 0.15.2 , xmonad >= 0.13