275 lines
8.4 KiB
Haskell
275 lines
8.4 KiB
Haskell
--------------------------------------------------------------------------------
|
|
-- 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<X>" where X is
|
|
-- usually 0, and each device is "/org/bluez/hci<X>/<MAC_ADDRESS>".
|
|
--
|
|
-- Simple and somewhat crude way to do this is to have two monitors, one
|
|
-- watching the powered state of the adaptor and one listening for connection
|
|
-- changes. The former is easy since this is just one /org/bluez/hciX. For the
|
|
-- latter, each 'Connected' property is embedded in each individual device path
|
|
-- on `org.bluez.Device1', so just watch the entire bluez bus for property
|
|
-- changes and filter those that correspond to the aforementioned
|
|
-- interface/property. Track all this in a state which keeps the powered
|
|
-- property and a running list of connected devices.
|
|
--
|
|
-- TODO also not sure if I need to care about multiple adapters and/or the
|
|
-- adapter changing. For now it should just get the first adaptor and only pay
|
|
-- attention to devices associated with it.
|
|
|
|
module Xmobar.Plugins.Bluetooth
|
|
( Bluetooth (..)
|
|
, btAlias
|
|
, btDep
|
|
)
|
|
where
|
|
|
|
import DBus
|
|
import DBus.Client
|
|
import Data.Internal.DBus
|
|
import Data.Internal.XIO
|
|
import RIO
|
|
import RIO.FilePath
|
|
import RIO.List
|
|
import qualified RIO.Map as M
|
|
import qualified RIO.Set as S
|
|
import qualified RIO.Text as T
|
|
import XMonad.Internal.DBus.Common
|
|
import Xmobar
|
|
import Xmobar.Plugins.Common
|
|
|
|
btAlias :: T.Text
|
|
btAlias = "bluetooth"
|
|
|
|
btDep :: DBusDependency_ SysClient
|
|
btDep =
|
|
Endpoint [Package Official "bluez"] btBus btOMPath omInterface $
|
|
Method_ getManagedObjects
|
|
|
|
data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
|
|
|
|
instance Exec Bluetooth where
|
|
alias (Bluetooth _ _) = T.unpack btAlias
|
|
start (Bluetooth icons colors) cb =
|
|
withDBusClientConnection cb Nothing (Just "bluetooth.log") $
|
|
startAdapter icons colors cb
|
|
|
|
startAdapter
|
|
:: Icons
|
|
-> Colors
|
|
-> Callback
|
|
-> NamedSysConnection
|
|
-> RIO SimpleApp ()
|
|
startAdapter is cs cb cl = do
|
|
state <- newMVar emptyState
|
|
let dpy cb' = displayIcon cb' (iconFormatter is cs)
|
|
mapRIO (PluginEnv cl state dpy cb) $ do
|
|
ot <- getBtObjectTree
|
|
case findAdaptor ot of
|
|
Nothing -> logError "could not find bluetooth adapter"
|
|
Just adaptor -> do
|
|
initAdapterState adaptor
|
|
initDevicesState adaptor ot
|
|
startAdaptorListener adaptor
|
|
startConnectedListener adaptor
|
|
pluginDisplay
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- 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 -> T.Text)
|
|
|
|
type Icons = (T.Text, T.Text)
|
|
|
|
displayIcon :: Callback -> IconFormatter -> BTIO ()
|
|
displayIcon callback formatter =
|
|
liftIO . callback . T.unpack . 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) cs powered connected =
|
|
maybe na (\p -> colorText cs p icon) powered
|
|
where
|
|
icon = if connected then iconConn else iconDisc
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Connection State
|
|
|
|
type BTIO = PluginIO BtState SysClient
|
|
|
|
data BtState = BtState
|
|
{ btDevices :: S.Set ObjectPath
|
|
, btPowered :: Maybe Bool
|
|
}
|
|
|
|
emptyState :: BtState
|
|
emptyState =
|
|
BtState
|
|
{ btDevices = S.empty
|
|
, btPowered = Nothing
|
|
}
|
|
|
|
readState :: BTIO (Maybe Bool, Bool)
|
|
readState = do
|
|
p <- readPowered
|
|
c <- readDevices
|
|
return (p, not $ null c)
|
|
|
|
modifyState :: (BtState -> BTIO (BtState, a)) -> BTIO a
|
|
modifyState f = do
|
|
m <- asks plugState
|
|
modifyMVar m f
|
|
|
|
beforeDisplay :: BTIO () -> BTIO ()
|
|
beforeDisplay f = f >> pluginDisplay
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Object manager
|
|
|
|
findAdaptor :: ObjectTree -> Maybe ObjectPath
|
|
findAdaptor = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys
|
|
|
|
-- | Search the object tree for devices which are in a connected state.
|
|
-- Return the object path for said devices.
|
|
findConnectedDevices :: ObjectPath -> ObjectTree -> [ObjectPath]
|
|
findConnectedDevices adaptor =
|
|
filter (adaptorHasDevice adaptor) . M.keys . M.filter isConnectedDev
|
|
where
|
|
isConnectedDev m = Just True == lookupState m
|
|
lookupState =
|
|
fromVariant
|
|
<=< M.lookup (memberNameT devConnected)
|
|
<=< M.lookup devInterface
|
|
|
|
adaptorHasDevice :: ObjectPath -> ObjectPath -> Bool
|
|
adaptorHasDevice adaptor device = case splitPathNoRoot device of
|
|
[org, bluez, hciX, _] -> splitPathNoRoot adaptor == [org, bluez, hciX]
|
|
_ -> False
|
|
|
|
splitPathNoRoot :: ObjectPath -> [FilePath]
|
|
splitPathNoRoot = dropWhile (== "/") . splitDirectories . formatObjectPath
|
|
|
|
getBtObjectTree
|
|
:: ( HasClient env
|
|
, SafeClient c
|
|
, MonadReader (env c) m
|
|
, HasLogFunc (env c)
|
|
, MonadUnliftIO m
|
|
)
|
|
=> m ObjectTree
|
|
getBtObjectTree = callGetManagedObjects btBus btOMPath
|
|
|
|
btOMPath :: ObjectPath
|
|
btOMPath = objectPath_ "/"
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Adapter
|
|
|
|
-- | Get powered state of adaptor and log the result
|
|
initAdapterState :: ObjectPath -> BTIO ()
|
|
initAdapterState adapter = do
|
|
reply <- callGetPowered adapter
|
|
putPowered $ fromSingletonVariant reply
|
|
|
|
matchBTProperty
|
|
:: ( SafeClient c
|
|
, HasClient env
|
|
, MonadReader (env c) m
|
|
, HasLogFunc (env c)
|
|
, MonadUnliftIO m
|
|
)
|
|
=> ObjectPath
|
|
-> m (Maybe MatchRule)
|
|
matchBTProperty p = matchPropertyFull btBus (Just p)
|
|
|
|
-- | Start a listener that monitors changes to the powered state of an adaptor
|
|
startAdaptorListener :: ObjectPath -> BTIO ()
|
|
startAdaptorListener adaptor = do
|
|
res <- matchBTProperty adaptor
|
|
case res of
|
|
Just rule -> void $ addMatchCallback rule callback
|
|
Nothing -> do
|
|
logError $
|
|
"could not add listener for prop "
|
|
<> displayMemberName adaptorPowered
|
|
<> " on path "
|
|
<> displayObjectPath adaptor
|
|
where
|
|
callback sig =
|
|
withNestedDBusClientConnection Nothing Nothing $
|
|
withSignalMatch procMatch $
|
|
matchPropertyChanged adaptorInterface adaptorPowered sig
|
|
procMatch = beforeDisplay . putPowered
|
|
|
|
callGetPowered
|
|
:: ( HasClient env
|
|
, MonadReader (env c) m
|
|
, HasLogFunc (env c)
|
|
, SafeClient c
|
|
, MonadUnliftIO m
|
|
)
|
|
=> ObjectPath
|
|
-> m [Variant]
|
|
callGetPowered adapter =
|
|
callPropertyGet btBus adapter adaptorInterface adaptorPowered
|
|
|
|
putPowered :: Maybe Bool -> BTIO ()
|
|
putPowered ds = modifyState $ \s -> return (s {btPowered = ds}, ())
|
|
|
|
readPowered :: BTIO (Maybe Bool)
|
|
readPowered = fmap btPowered $ readMVar =<< asks plugState
|
|
|
|
adaptorInterface :: InterfaceName
|
|
adaptorInterface = interfaceName_ "org.bluez.Adapter1"
|
|
|
|
adaptorPowered :: MemberName
|
|
adaptorPowered = "Powered"
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Devices
|
|
|
|
initDevicesState :: ObjectPath -> ObjectTree -> BTIO ()
|
|
initDevicesState adaptor ot = do
|
|
let devices = findConnectedDevices adaptor ot
|
|
modifyState $ \s -> return (s {btDevices = S.fromList devices}, ())
|
|
|
|
startConnectedListener :: ObjectPath -> BTIO ()
|
|
startConnectedListener adaptor = do
|
|
reply <- matchPropertyFull btBus Nothing
|
|
case reply of
|
|
Just rule -> do
|
|
void $ addMatchCallbackSignal rule callback
|
|
logInfo $ "Started listening for device connections on " <> adaptor_
|
|
Nothing -> logError "Could not listen for connection changes"
|
|
where
|
|
adaptor_ = displayWrapQuote $ displayObjectPath adaptor
|
|
callback sig =
|
|
withNestedDBusClientConnection Nothing Nothing $ do
|
|
let devpath = signalPath sig
|
|
when (adaptorHasDevice adaptor devpath) $
|
|
withSignalMatch (update devpath) $
|
|
matchConnected $
|
|
signalBody sig
|
|
matchConnected = matchPropertyChanged devInterface devConnected
|
|
update _ Nothing = return ()
|
|
update devpath (Just x) = do
|
|
let f = if x then S.insert else S.delete
|
|
beforeDisplay $
|
|
modifyState $
|
|
\s -> return (s {btDevices = f devpath $ btDevices s}, ())
|
|
|
|
readDevices :: BTIO (S.Set ObjectPath)
|
|
readDevices = fmap btDevices $ readMVar =<< asks plugState
|
|
|
|
devInterface :: InterfaceName
|
|
devInterface = interfaceName_ "org.bluez.Device1"
|
|
|
|
devConnected :: MemberName
|
|
devConnected = "Connected"
|