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