ENH make bluetooth module display connection status
This commit is contained in:
parent
5eb7a573ec
commit
8282cf05cc
|
@ -63,9 +63,9 @@ main = do
|
||||||
config :: BarRegions -> String -> Config
|
config :: BarRegions -> String -> Config
|
||||||
config br confDir = defaultConfig
|
config br confDir = defaultConfig
|
||||||
{ font = barFont
|
{ font = barFont
|
||||||
, additionalFonts = [iconFont, iconFontLarge, iconFontXLarge]
|
, additionalFonts = [iconFont, iconFontLarge, iconFontXLarge, iconFontXXLarge]
|
||||||
, textOffset = 16
|
, textOffset = 16
|
||||||
, textOffsets = [16, 17, 18]
|
, textOffsets = [16, 17, 17, 18]
|
||||||
, bgColor = T.bgColor
|
, bgColor = T.bgColor
|
||||||
, fgColor = T.fgColor
|
, fgColor = T.fgColor
|
||||||
, position = BottomSize C 100 24
|
, position = BottomSize C 100 24
|
||||||
|
@ -161,7 +161,8 @@ btCmd :: CmdSpec
|
||||||
btCmd = CmdSpec
|
btCmd = CmdSpec
|
||||||
{ csAlias = btAlias
|
{ csAlias = btAlias
|
||||||
, csRunnable = Run
|
, csRunnable = Run
|
||||||
$ Bluetooth ("<fn=2>\xf293</fn>", T.fgColor, T.backdropFgColor)
|
-- $ Bluetooth ("<fn=2>\xf293</fn>", T.fgColor, T.backdropFgColor)
|
||||||
|
$ Bluetooth ("<fn=3>\xf5b0</fn>", "<fn=3>\xf5ae</fn>") (T.fgColor, T.backdropFgColor)
|
||||||
}
|
}
|
||||||
|
|
||||||
alsaCmd :: CmdSpec
|
alsaCmd :: CmdSpec
|
||||||
|
@ -202,10 +203,10 @@ lockCmd = CmdSpec
|
||||||
{ csAlias = "locks"
|
{ csAlias = "locks"
|
||||||
, csRunnable = Run
|
, csRunnable = Run
|
||||||
$ Locks
|
$ Locks
|
||||||
[ "-N", "<fn=3>\xf8a5</fn>"
|
[ "-N", "<fn=4>\xf8a5</fn>"
|
||||||
, "-n", xmobarColor T.backdropFgColor "" "<fn=3>\xf8a5</fn>"
|
, "-n", xmobarColor T.backdropFgColor "" "<fn=4>\xf8a5</fn>"
|
||||||
, "-C", "<fn=3>\xf657</fn>"
|
, "-C", "<fn=3>\xf657</fn>"
|
||||||
, "-c", xmobarColor T.backdropFgColor "" "<fn=3>\xf657</fn>"
|
, "-c", xmobarColor T.backdropFgColor "" "<fn=4>\xf657</fn>"
|
||||||
, "-s", ""
|
, "-s", ""
|
||||||
, "-S", ""
|
, "-S", ""
|
||||||
, "-d", " "
|
, "-d", " "
|
||||||
|
@ -405,4 +406,7 @@ iconFontLarge :: String
|
||||||
iconFontLarge = nerdFont 15
|
iconFontLarge = nerdFont 15
|
||||||
|
|
||||||
iconFontXLarge :: String
|
iconFontXLarge :: String
|
||||||
iconFontXLarge = nerdFont 20
|
iconFontXLarge = nerdFont 18
|
||||||
|
|
||||||
|
iconFontXXLarge :: String
|
||||||
|
iconFontXXLarge = nerdFont 20
|
||||||
|
|
|
@ -11,7 +11,7 @@ module XMonad.Internal.DBus.Brightness.Common
|
||||||
, signalDep
|
, signalDep
|
||||||
) where
|
) where
|
||||||
|
|
||||||
-- import Control.Monad (void)
|
import Control.Monad (void)
|
||||||
|
|
||||||
import Data.Int (Int32)
|
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 :: Num c => BrightnessConfig a b -> (Maybe c -> IO ()) -> Client -> IO ()
|
||||||
matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
|
matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
|
||||||
addMatchCallback brMatcher (cb . bodyGetBrightness)
|
void . addMatchCallback brMatcher (cb . bodyGetBrightness)
|
||||||
where
|
where
|
||||||
brMatcher = matchAny
|
brMatcher = matchAny
|
||||||
{ matchPath = Just p
|
{ matchPath = Just p
|
||||||
|
|
|
@ -6,16 +6,17 @@ module XMonad.Internal.DBus.Common
|
||||||
, getDBusClient
|
, getDBusClient
|
||||||
, withDBusClient
|
, withDBusClient
|
||||||
, withDBusClient_
|
, withDBusClient_
|
||||||
, withDBusClientConnection_
|
|
||||||
, matchProperty
|
, matchProperty
|
||||||
|
, matchProperty'
|
||||||
, xmonadBusName
|
, xmonadBusName
|
||||||
, matchPropertyChanged
|
, matchPropertyChanged
|
||||||
, SignalMatch(..)
|
, SignalMatch(..)
|
||||||
|
, SignalCallback
|
||||||
|
, withSignalMatch
|
||||||
, callPropertyGet
|
, callPropertyGet
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Exception
|
import Control.Exception
|
||||||
import Control.Monad
|
|
||||||
|
|
||||||
import qualified Data.Map.Strict as M
|
import qualified Data.Map.Strict as M
|
||||||
|
|
||||||
|
@ -25,9 +26,11 @@ import DBus.Client
|
||||||
xmonadBusName :: BusName
|
xmonadBusName :: BusName
|
||||||
xmonadBusName = busName_ "org.xmonad"
|
xmonadBusName = busName_ "org.xmonad"
|
||||||
|
|
||||||
|
type SignalCallback = [Variant] -> IO ()
|
||||||
|
|
||||||
-- | Bind a callback to a signal match rule
|
-- | Bind a callback to a signal match rule
|
||||||
addMatchCallback :: MatchRule -> ([Variant] -> IO ()) -> Client -> IO ()
|
addMatchCallback :: MatchRule -> SignalCallback -> Client -> IO SignalHandler
|
||||||
addMatchCallback rule cb client = void $ addMatch client rule $ cb . signalBody
|
addMatchCallback rule cb client = addMatch client rule $ cb . signalBody
|
||||||
|
|
||||||
getDBusClient :: Bool -> IO (Maybe Client)
|
getDBusClient :: Bool -> IO (Maybe Client)
|
||||||
getDBusClient sys = do
|
getDBusClient sys = do
|
||||||
|
@ -49,46 +52,50 @@ withDBusClient_ sys f = do
|
||||||
mapM_ f client
|
mapM_ f client
|
||||||
mapM_ disconnect client
|
mapM_ disconnect client
|
||||||
|
|
||||||
withDBusClientConnection_ :: Bool -> (Client -> IO ()) -> IO ()
|
|
||||||
withDBusClientConnection_ sys f = do
|
|
||||||
client <- getDBusClient sys
|
|
||||||
mapM_ f client
|
|
||||||
|
|
||||||
propertyInterface :: InterfaceName
|
propertyInterface :: InterfaceName
|
||||||
propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
|
propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
|
||||||
|
|
||||||
propertySignal :: MemberName
|
propertySignal :: MemberName
|
||||||
propertySignal = memberName_ "PropertiesChanged"
|
propertySignal = memberName_ "PropertiesChanged"
|
||||||
|
|
||||||
matchProperty :: ObjectPath -> MatchRule
|
matchProperty' :: Maybe ObjectPath -> MatchRule
|
||||||
matchProperty p = matchAny
|
matchProperty' p = matchAny
|
||||||
-- NOTE: the sender for signals is usually the unique name (eg :X.Y) not the
|
-- 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
|
-- requested name (eg "org.something.understandable"). If sender is included
|
||||||
-- here, likely nothing will match. Solution is to somehow get the unique
|
-- here, likely nothing will match. Solution is to somehow get the unique
|
||||||
-- name, which I could do, but probably won't
|
-- name, which I could do, but probably won't
|
||||||
{ matchPath = Just p
|
{ matchPath = p
|
||||||
, matchInterface = Just propertyInterface
|
, matchInterface = Just propertyInterface
|
||||||
, matchMember = Just propertySignal
|
, matchMember = Just propertySignal
|
||||||
}
|
}
|
||||||
|
|
||||||
|
matchProperty :: ObjectPath -> MatchRule
|
||||||
|
matchProperty = matchProperty' . Just
|
||||||
|
|
||||||
data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show)
|
data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show)
|
||||||
|
|
||||||
matchPropertyChanged :: InterfaceName -> String -> (Variant -> Maybe a)
|
withSignalMatch :: (Maybe a -> IO ()) -> SignalMatch a -> IO ()
|
||||||
-> [Variant] -> SignalMatch a
|
withSignalMatch f (Match x) = f (Just x)
|
||||||
matchPropertyChanged iface property f [i, body, _] =
|
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)
|
let i' = (fromVariant i :: Maybe String)
|
||||||
b = toMap body in
|
b = toMap body in
|
||||||
case (i', b) of
|
case (i', b) of
|
||||||
(Just i'', Just b') -> if i'' == formatInterfaceName iface then
|
(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
|
else NoMatch
|
||||||
_ -> Failure
|
_ -> Failure
|
||||||
where
|
where
|
||||||
toMap v = fromVariant v :: Maybe (M.Map String Variant)
|
toMap v = fromVariant v :: Maybe (M.Map String Variant)
|
||||||
matchPropertyChanged _ _ _ _ = Failure
|
matchPropertyChanged _ _ _ = Failure
|
||||||
|
|
||||||
callPropertyGet :: BusName -> ObjectPath -> InterfaceName -> String -> Client
|
callPropertyGet :: BusName -> ObjectPath -> InterfaceName -> String -> Client
|
||||||
-> IO [Variant]
|
-> IO [Variant]
|
||||||
callPropertyGet bus path iface property client = either (const []) (:[])
|
callPropertyGet bus path iface property client = either (const []) (:[])
|
||||||
<$> getProperty client (methodCall path iface $ memberName_ property)
|
<$> getProperty client (methodCall path iface $ memberName_ property)
|
||||||
{ methodCallDestination = Just bus }
|
{ methodCallDestination = Just bus }
|
||||||
|
|
||||||
|
|
|
@ -130,7 +130,8 @@ callQuery client = do
|
||||||
return $ either (const Nothing) bodyGetCurrentState reply
|
return $ either (const Nothing) bodyGetCurrentState reply
|
||||||
|
|
||||||
matchSignal :: (Maybe SSState -> IO ()) -> Client -> IO ()
|
matchSignal :: (Maybe SSState -> IO ()) -> Client -> IO ()
|
||||||
matchSignal cb = addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState
|
matchSignal cb =
|
||||||
|
fmap void . addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState
|
||||||
|
|
||||||
ssSignalDep :: DBusDep
|
ssSignalDep :: DBusDep
|
||||||
ssSignalDep = Endpoint xmonadBusName ssPath interface $ Signal_ memState
|
ssSignalDep = Endpoint xmonadBusName ssPath interface $ Signal_ memState
|
||||||
|
|
|
@ -36,6 +36,12 @@ module XMonad.Internal.Dependency
|
||||||
, executeFeatureWith_
|
, executeFeatureWith_
|
||||||
, callMethod
|
, callMethod
|
||||||
, callMethod'
|
, callMethod'
|
||||||
|
, callGetManagedObjects
|
||||||
|
, ObjectTree
|
||||||
|
, getManagedObjects
|
||||||
|
, omInterface
|
||||||
|
, addInterfaceAddedListener
|
||||||
|
, addInterfaceRemovedListener
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
|
@ -43,17 +49,23 @@ import Control.Monad.Identity
|
||||||
|
|
||||||
import Data.Bifunctor (bimap)
|
import Data.Bifunctor (bimap)
|
||||||
import Data.List (find)
|
import Data.List (find)
|
||||||
|
import qualified Data.Map as M
|
||||||
import Data.Maybe (catMaybes, fromMaybe, listToMaybe)
|
import Data.Maybe (catMaybes, fromMaybe, listToMaybe)
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
import DBus.Client
|
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.Environment
|
||||||
import System.Exit
|
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.IO
|
||||||
import XMonad.Internal.Process
|
import XMonad.Internal.Process
|
||||||
import XMonad.Internal.Shell
|
import XMonad.Internal.Shell
|
||||||
|
@ -376,3 +388,42 @@ dbusDepSatisfied client (Endpoint busname objpath iface mem) = do
|
||||||
, "on bus"
|
, "on bus"
|
||||||
, formatBusName busname
|
, 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
|
||||||
|
|
|
@ -8,13 +8,12 @@ module Xmobar.Plugins.BacklightCommon (startBacklight) where
|
||||||
|
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
|
|
||||||
import XMonad.Internal.DBus.Common
|
|
||||||
import Xmobar.Plugins.Common
|
import Xmobar.Plugins.Common
|
||||||
|
|
||||||
startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> Client -> IO ())
|
startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> Client -> IO ())
|
||||||
-> (Client -> IO (Maybe a)) -> String -> (String -> IO ()) -> IO ()
|
-> (Client -> IO (Maybe a)) -> String -> (String -> IO ()) -> IO ()
|
||||||
startBacklight matchSignal callGetBrightness icon cb = do
|
startBacklight matchSignal callGetBrightness icon cb = do
|
||||||
withDBusClientConnection_ False $ \c -> do
|
withDBusClientConnection False cb $ \c -> do
|
||||||
matchSignal (cb . formatBrightness) c
|
matchSignal (cb . formatBrightness) c
|
||||||
cb . formatBrightness =<< callGetBrightness c
|
cb . formatBrightness =<< callGetBrightness c
|
||||||
where
|
where
|
||||||
|
|
|
@ -2,6 +2,33 @@
|
||||||
-- | Bluetooth plugin
|
-- | Bluetooth plugin
|
||||||
--
|
--
|
||||||
-- Use the bluez interface on DBus to check status
|
-- 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<X>" where X is
|
||||||
|
-- usually 0, and each device is "/org/bluez/hci<X>/<MAC_ADDRESS>".
|
||||||
|
--
|
||||||
|
-- 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
|
module Xmobar.Plugins.Bluetooth
|
||||||
( Bluetooth(..)
|
( Bluetooth(..)
|
||||||
|
@ -9,6 +36,14 @@ module Xmobar.Plugins.Bluetooth
|
||||||
, btDep
|
, btDep
|
||||||
) where
|
) 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
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
|
|
||||||
|
@ -17,42 +52,225 @@ import XMonad.Internal.Dependency
|
||||||
import Xmobar
|
import Xmobar
|
||||||
import Xmobar.Plugins.Common
|
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 :: String
|
||||||
btAlias = "bluetooth"
|
btAlias = "bluetooth"
|
||||||
|
|
||||||
btDep :: DBusDep
|
btDep :: DBusDep
|
||||||
btDep = Endpoint btBus btPath btInterface $ Property_ btPowered
|
btDep = Endpoint btBus btOmPath omInterface $ Method_ getManagedObjects
|
||||||
|
|
||||||
matchPowered :: [Variant] -> SignalMatch Bool
|
data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
|
||||||
matchPowered = matchPropertyChanged btInterface btPowered fromVariant
|
|
||||||
|
|
||||||
callGetPowered :: Client -> IO [Variant]
|
|
||||||
callGetPowered = callPropertyGet btBus btPath btInterface btPowered
|
|
||||||
|
|
||||||
instance Exec Bluetooth where
|
instance Exec Bluetooth where
|
||||||
alias (Bluetooth _) = btAlias
|
alias (Bluetooth _ _) = btAlias
|
||||||
start (Bluetooth (text, colorOn, colorOff)) cb = do
|
start (Bluetooth icons colors) cb =
|
||||||
withDBusClientConnection_ True $ \c -> do
|
withDBusClientConnection True cb $ startAdapter icons colors cb
|
||||||
startListener rule callGetPowered matchPowered chooseColor' cb c
|
|
||||||
where
|
|
||||||
rule = matchProperty btPath
|
|
||||||
chooseColor' = chooseColor text colorOn colorOff
|
|
||||||
|
|
||||||
|
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"
|
||||||
|
|
|
@ -2,10 +2,16 @@
|
||||||
module Xmobar.Plugins.Common
|
module Xmobar.Plugins.Common
|
||||||
( chooseColor
|
( chooseColor
|
||||||
, startListener
|
, startListener
|
||||||
|
, procSignalMatch
|
||||||
, na
|
, na
|
||||||
|
, fromSingletonVariant
|
||||||
|
, withDBusClientConnection
|
||||||
|
, Callback
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
import Control.Monad
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
|
|
||||||
|
@ -14,17 +20,22 @@ import Data.Maybe
|
||||||
import XMonad.Hooks.DynamicLog (xmobarColor)
|
import XMonad.Hooks.DynamicLog (xmobarColor)
|
||||||
import XMonad.Internal.DBus.Common
|
import XMonad.Internal.DBus.Common
|
||||||
|
|
||||||
|
type Callback = String -> IO ()
|
||||||
|
|
||||||
startListener :: IsVariant a => MatchRule -> (Client -> IO [Variant])
|
startListener :: IsVariant a => MatchRule -> (Client -> IO [Variant])
|
||||||
-> ([Variant] -> SignalMatch a) -> (a -> String) -> (String -> IO ())
|
-> ([Variant] -> SignalMatch a) -> (a -> IO String) -> Callback
|
||||||
-> Client -> IO ()
|
-> Client -> IO ()
|
||||||
startListener rule getProp fromSignal toColor cb client = do
|
startListener rule getProp fromSignal toColor cb client = do
|
||||||
reply <- getProp client
|
reply <- getProp client
|
||||||
procMatch $ maybe Failure Match $ fromVariant =<< listToMaybe reply
|
procMatch $ maybe Failure Match $ fromVariant =<< listToMaybe reply
|
||||||
addMatchCallback rule (procMatch . fromSignal) client
|
void $ addMatchCallback rule (procMatch . fromSignal) client
|
||||||
where
|
where
|
||||||
procMatch (Match t) = cb $ toColor t
|
procMatch = procSignalMatch cb toColor
|
||||||
procMatch Failure = cb na
|
|
||||||
procMatch NoMatch = return ()
|
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 :: String -> String -> String -> Bool -> String
|
||||||
chooseColor text colorOn colorOff state =
|
chooseColor text colorOn colorOff state =
|
||||||
|
@ -32,3 +43,9 @@ chooseColor text colorOn colorOff state =
|
||||||
|
|
||||||
na :: String
|
na :: String
|
||||||
na = "N/A"
|
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
|
||||||
|
|
|
@ -58,15 +58,15 @@ getDeviceConnected :: ObjectPath -> Client -> IO [Variant]
|
||||||
getDeviceConnected path = callPropertyGet nmBus path nmDeviceInterface devSignal
|
getDeviceConnected path = callPropertyGet nmBus path nmDeviceInterface devSignal
|
||||||
|
|
||||||
matchStatus :: [Variant] -> SignalMatch Word32
|
matchStatus :: [Variant] -> SignalMatch Word32
|
||||||
matchStatus = matchPropertyChanged nmDeviceInterface devSignal fromVariant
|
matchStatus = matchPropertyChanged nmDeviceInterface devSignal
|
||||||
|
|
||||||
instance Exec Device where
|
instance Exec Device where
|
||||||
alias (Device (iface, _, _, _)) = iface
|
alias (Device (iface, _, _, _)) = iface
|
||||||
start (Device (iface, text, colorOn, colorOff)) cb = do
|
start (Device (iface, text, colorOn, colorOff)) cb = do
|
||||||
withDBusClientConnection_ True $ \c -> do
|
withDBusClientConnection True cb $ \c -> do
|
||||||
path <- getDevice c iface
|
path <- getDevice c iface
|
||||||
maybe (cb na) (listener c) path
|
maybe (cb na) (listener c) path
|
||||||
where
|
where
|
||||||
listener client path = startListener (matchProperty path)
|
listener client path = startListener (matchProperty path)
|
||||||
(getDeviceConnected path) matchStatus chooseColor' cb client
|
(getDeviceConnected path) matchStatus chooseColor' cb client
|
||||||
chooseColor' = chooseColor text colorOn colorOff . (> 1)
|
chooseColor' = return . chooseColor text colorOn colorOff . (> 1)
|
||||||
|
|
|
@ -11,7 +11,6 @@ module Xmobar.Plugins.Screensaver
|
||||||
|
|
||||||
import Xmobar
|
import Xmobar
|
||||||
|
|
||||||
import XMonad.Internal.DBus.Common
|
|
||||||
import XMonad.Internal.DBus.Screensaver
|
import XMonad.Internal.DBus.Screensaver
|
||||||
import Xmobar.Plugins.Common
|
import Xmobar.Plugins.Common
|
||||||
|
|
||||||
|
@ -23,7 +22,7 @@ ssAlias = "screensaver"
|
||||||
instance Exec Screensaver where
|
instance Exec Screensaver where
|
||||||
alias (Screensaver _) = ssAlias
|
alias (Screensaver _) = ssAlias
|
||||||
start (Screensaver (text, colorOn, colorOff)) cb = do
|
start (Screensaver (text, colorOn, colorOff)) cb = do
|
||||||
withDBusClientConnection_ False $ \c -> do
|
withDBusClientConnection False cb $ \c -> do
|
||||||
matchSignal (cb . fmtState) c
|
matchSignal (cb . fmtState) c
|
||||||
cb . fmtState =<< callQuery c
|
cb . fmtState =<< callQuery c
|
||||||
where
|
where
|
||||||
|
|
|
@ -39,10 +39,10 @@ vpnDep = Endpoint vpnBus vpnPath vpnInterface $ Property_ vpnConnType
|
||||||
instance Exec VPN where
|
instance Exec VPN where
|
||||||
alias (VPN _) = vpnAlias
|
alias (VPN _) = vpnAlias
|
||||||
start (VPN (text, colorOn, colorOff)) cb =
|
start (VPN (text, colorOn, colorOff)) cb =
|
||||||
withDBusClientConnection_ True
|
withDBusClientConnection True cb
|
||||||
$ startListener rule getProp fromSignal chooseColor' cb
|
$ startListener rule getProp fromSignal chooseColor' cb
|
||||||
where
|
where
|
||||||
rule = matchProperty vpnPath
|
rule = matchProperty vpnPath
|
||||||
getProp = callPropertyGet vpnBus vpnPath vpnInterface vpnConnType
|
getProp = callPropertyGet vpnBus vpnPath vpnInterface vpnConnType
|
||||||
fromSignal = matchPropertyChanged vpnInterface vpnConnType fromVariant
|
fromSignal = matchPropertyChanged vpnInterface vpnConnType
|
||||||
chooseColor' = chooseColor text colorOn colorOff . ("vpn" ==)
|
chooseColor' = return . chooseColor text colorOn colorOff . ("vpn" ==)
|
||||||
|
|
|
@ -47,6 +47,7 @@ library
|
||||||
, directory >= 1.3.3.0
|
, directory >= 1.3.3.0
|
||||||
, process >= 1.6.5.0
|
, process >= 1.6.5.0
|
||||||
, filepath >= 1.4.2.1
|
, filepath >= 1.4.2.1
|
||||||
|
, split >= 0.2.3.4
|
||||||
, xmobar
|
, xmobar
|
||||||
, xmonad-extras >= 0.15.2
|
, xmonad-extras >= 0.15.2
|
||||||
, xmonad >= 0.13
|
, xmonad >= 0.13
|
||||||
|
|
Loading…
Reference in New Issue