REF use submonad for bluetooth state
This commit is contained in:
parent
9d7ca49357
commit
37f607d817
|
@ -68,28 +68,30 @@ instance Exec Bluetooth where
|
||||||
withDBusClientConnection cb "bluetooth" $ startAdapter icons colors cb
|
withDBusClientConnection cb "bluetooth" $ startAdapter icons colors cb
|
||||||
|
|
||||||
startAdapter
|
startAdapter
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: Icons
|
||||||
=> Icons
|
|
||||||
-> Colors
|
-> Colors
|
||||||
-> Callback
|
-> Callback
|
||||||
-> SysClient
|
-> SysClient
|
||||||
-> m ()
|
-> RIO SimpleApp ()
|
||||||
startAdapter is cs cb cl = do
|
startAdapter is cs cb cl = do
|
||||||
ot <- getBtObjectTree cl
|
|
||||||
state <- newMVar emptyState
|
state <- newMVar emptyState
|
||||||
let dpy = displayIcon cb (iconFormatter is cs) state
|
let dpy = displayIcon cb (iconFormatter is cs)
|
||||||
|
mapRIO (wrap state) $ do
|
||||||
|
ot <- getBtObjectTree cl
|
||||||
-- TODO if this fails it won't be logged
|
-- TODO if this fails it won't be logged
|
||||||
forM_ (findAdapter ot) $ \adapter -> do
|
forM_ (findAdapter ot) $ \adapter -> do
|
||||||
-- set up adapter
|
-- set up adapter
|
||||||
initAdapter state adapter cl
|
initAdapter adapter cl
|
||||||
void $ addAdaptorListener state dpy adapter cl
|
void $ addAdaptorListener dpy adapter cl
|
||||||
-- set up devices on the adapter (and listeners for adding/removing devices)
|
-- set up devices on the adapter (and listeners for adding/removing devices)
|
||||||
let devices = findDevices adapter ot
|
let devices = findDevices adapter ot
|
||||||
addDeviceAddedListener state dpy adapter cl
|
addDeviceAddedListener dpy adapter cl
|
||||||
addDeviceRemovedListener state dpy adapter cl
|
addDeviceRemovedListener dpy adapter cl
|
||||||
forM_ devices $ \d -> addAndInitDevice state dpy d cl
|
forM_ devices $ \d -> addAndInitDevice dpy d cl
|
||||||
-- after setting things up, show the icon based on the initialized state
|
-- after setting things up, show the icon based on the initialized state
|
||||||
dpy
|
dpy
|
||||||
|
where
|
||||||
|
wrap s env = BTEnv {btEnv = env, btState = s}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Icon Display
|
-- Icon Display
|
||||||
|
@ -101,9 +103,9 @@ type IconFormatter = (Maybe Bool -> Bool -> T.Text)
|
||||||
|
|
||||||
type Icons = (T.Text, T.Text)
|
type Icons = (T.Text, T.Text)
|
||||||
|
|
||||||
displayIcon :: MonadUnliftIO m => Callback -> IconFormatter -> MutableBtState -> m ()
|
displayIcon :: Callback -> IconFormatter -> BTIO ()
|
||||||
displayIcon callback formatter =
|
displayIcon callback formatter =
|
||||||
liftIO . callback . T.unpack . uncurry formatter <=< readState
|
liftIO . callback . T.unpack . uncurry formatter =<< readState
|
||||||
|
|
||||||
-- TODO maybe I want this to fail when any of the device statuses are Nothing
|
-- TODO maybe I want this to fail when any of the device statuses are Nothing
|
||||||
iconFormatter :: Icons -> Colors -> IconFormatter
|
iconFormatter :: Icons -> Colors -> IconFormatter
|
||||||
|
@ -120,6 +122,16 @@ iconFormatter (iconConn, iconDisc) cs powered connected =
|
||||||
-- is to track the shared state of the bluetooth adaptor and its devices using
|
-- is to track the shared state of the bluetooth adaptor and its devices using
|
||||||
-- an MVar.
|
-- an MVar.
|
||||||
|
|
||||||
|
data BTEnv = BTEnv
|
||||||
|
{ btEnv :: !SimpleApp
|
||||||
|
, btState :: !(MVar BtState)
|
||||||
|
}
|
||||||
|
|
||||||
|
instance HasLogFunc BTEnv where
|
||||||
|
logFuncL = lens btEnv (\x y -> x {btEnv = y}) . logFuncL
|
||||||
|
|
||||||
|
type BTIO = RIO BTEnv
|
||||||
|
|
||||||
data BTDevice = BTDevice
|
data BTDevice = BTDevice
|
||||||
{ btDevConnected :: Maybe Bool
|
{ btDevConnected :: Maybe Bool
|
||||||
, btDevSigHandler :: SignalHandler
|
, btDevSigHandler :: SignalHandler
|
||||||
|
@ -132,8 +144,6 @@ data BtState = BtState
|
||||||
, btPowered :: Maybe Bool
|
, btPowered :: Maybe Bool
|
||||||
}
|
}
|
||||||
|
|
||||||
type MutableBtState = MVar BtState
|
|
||||||
|
|
||||||
emptyState :: BtState
|
emptyState :: BtState
|
||||||
emptyState =
|
emptyState =
|
||||||
BtState
|
BtState
|
||||||
|
@ -141,10 +151,10 @@ emptyState =
|
||||||
, btPowered = Nothing
|
, btPowered = Nothing
|
||||||
}
|
}
|
||||||
|
|
||||||
readState :: MonadUnliftIO m => MutableBtState -> m (Maybe Bool, Bool)
|
readState :: BTIO (Maybe Bool, Bool)
|
||||||
readState state = do
|
readState = do
|
||||||
p <- readPowered state
|
p <- readPowered
|
||||||
c <- readDevices state
|
c <- readDevices
|
||||||
return (p, anyDevicesConnected c)
|
return (p, anyDevicesConnected c)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
@ -180,31 +190,19 @@ addBtOMListener
|
||||||
-> m ()
|
-> m ()
|
||||||
addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc
|
addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc
|
||||||
|
|
||||||
addDeviceAddedListener
|
addDeviceAddedListener :: BTIO () -> ObjectPath -> SysClient -> BTIO ()
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
addDeviceAddedListener dpy adapter client =
|
||||||
=> MutableBtState
|
|
||||||
-> m ()
|
|
||||||
-> ObjectPath
|
|
||||||
-> SysClient
|
|
||||||
-> m ()
|
|
||||||
addDeviceAddedListener state dpy adapter client =
|
|
||||||
addBtOMListener addDevice client
|
addBtOMListener addDevice client
|
||||||
where
|
where
|
||||||
addDevice = pathCallback adapter dpy $ \d ->
|
addDevice = pathCallback adapter dpy $ \d ->
|
||||||
addAndInitDevice state dpy d client
|
addAndInitDevice dpy d client
|
||||||
|
|
||||||
addDeviceRemovedListener
|
addDeviceRemovedListener :: BTIO () -> ObjectPath -> SysClient -> BTIO ()
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
addDeviceRemovedListener dpy adapter sys =
|
||||||
=> MutableBtState
|
|
||||||
-> m ()
|
|
||||||
-> ObjectPath
|
|
||||||
-> SysClient
|
|
||||||
-> m ()
|
|
||||||
addDeviceRemovedListener state dpy adapter sys =
|
|
||||||
addBtOMListener remDevice sys
|
addBtOMListener remDevice sys
|
||||||
where
|
where
|
||||||
remDevice = pathCallback adapter dpy $ \d -> do
|
remDevice = pathCallback adapter dpy $ \d -> do
|
||||||
old <- removeDevice state d
|
old <- removeDevice d
|
||||||
forM_ old $ liftIO . removeMatch (toClient sys) . btDevSigHandler
|
forM_ old $ liftIO . removeMatch (toClient sys) . btDevSigHandler
|
||||||
|
|
||||||
pathCallback
|
pathCallback
|
||||||
|
@ -220,18 +218,13 @@ pathCallback _ _ _ _ = return ()
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Adapter
|
-- Adapter
|
||||||
|
|
||||||
initAdapter
|
initAdapter :: ObjectPath -> SysClient -> BTIO ()
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
initAdapter adapter client = do
|
||||||
=> MutableBtState
|
|
||||||
-> ObjectPath
|
|
||||||
-> SysClient
|
|
||||||
-> m ()
|
|
||||||
initAdapter state adapter client = do
|
|
||||||
reply <- callGetPowered adapter client
|
reply <- callGetPowered adapter client
|
||||||
logInfo $ "initializing adapter at path " <> adapter_
|
logInfo $ "initializing adapter at path " <> adapter_
|
||||||
-- TODO this could fail if the variant is something weird; the only
|
-- TODO this could fail if the variant is something weird; the only
|
||||||
-- indication I will get is "NA"
|
-- indication I will get is "NA"
|
||||||
putPowered state $ fromSingletonVariant reply
|
putPowered $ fromSingletonVariant reply
|
||||||
where
|
where
|
||||||
adapter_ = displayWrapQuote $ displayObjectPath adapter
|
adapter_ = displayWrapQuote $ displayObjectPath adapter
|
||||||
|
|
||||||
|
@ -268,16 +261,14 @@ withBTPropertyRule cl path update iface prop = do
|
||||||
matchConnected = matchPropertyChanged iface prop
|
matchConnected = matchPropertyChanged iface prop
|
||||||
|
|
||||||
addAdaptorListener
|
addAdaptorListener
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: BTIO ()
|
||||||
=> MutableBtState
|
|
||||||
-> m ()
|
|
||||||
-> ObjectPath
|
-> ObjectPath
|
||||||
-> SysClient
|
-> SysClient
|
||||||
-> m (Maybe SignalHandler)
|
-> BTIO (Maybe SignalHandler)
|
||||||
addAdaptorListener state dpy adaptor sys = do
|
addAdaptorListener dpy adaptor sys = do
|
||||||
withBTPropertyRule sys adaptor procMatch adapterInterface adaptorPowered
|
withBTPropertyRule sys adaptor procMatch adapterInterface adaptorPowered
|
||||||
where
|
where
|
||||||
procMatch b = putPowered state b >> dpy
|
procMatch b = putPowered b >> dpy
|
||||||
|
|
||||||
callGetPowered
|
callGetPowered
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
|
@ -289,11 +280,13 @@ callGetPowered adapter =
|
||||||
memberName_ $
|
memberName_ $
|
||||||
T.unpack adaptorPowered
|
T.unpack adaptorPowered
|
||||||
|
|
||||||
putPowered :: MonadUnliftIO m => MutableBtState -> Maybe Bool -> m ()
|
putPowered :: Maybe Bool -> BTIO ()
|
||||||
putPowered m ds = modifyMVar_ m (\s -> return s {btPowered = ds})
|
putPowered ds = do
|
||||||
|
m <- asks btState
|
||||||
|
modifyMVar_ m (\s -> return s {btPowered = ds})
|
||||||
|
|
||||||
readPowered :: MonadUnliftIO m => MutableBtState -> m (Maybe Bool)
|
readPowered :: BTIO (Maybe Bool)
|
||||||
readPowered = fmap btPowered . readMVar
|
readPowered = fmap btPowered $ readMVar =<< asks btState
|
||||||
|
|
||||||
adapterInterface :: InterfaceName
|
adapterInterface :: InterfaceName
|
||||||
adapterInterface = interfaceName_ "org.bluez.Adapter1"
|
adapterInterface = interfaceName_ "org.bluez.Adapter1"
|
||||||
|
@ -304,50 +297,32 @@ adaptorPowered = "Powered"
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Devices
|
-- Devices
|
||||||
|
|
||||||
addAndInitDevice
|
addAndInitDevice :: BTIO () -> ObjectPath -> SysClient -> BTIO ()
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
addAndInitDevice dpy device client = do
|
||||||
=> MutableBtState
|
res <- addDeviceListener dpy device client
|
||||||
-> m ()
|
|
||||||
-> ObjectPath
|
|
||||||
-> SysClient
|
|
||||||
-> m ()
|
|
||||||
addAndInitDevice state dpy device client = do
|
|
||||||
res <- addDeviceListener state dpy device client
|
|
||||||
case res of
|
case res of
|
||||||
Just handler -> do
|
Just handler -> do
|
||||||
logInfo $ "initializing device at path " <> device_
|
logInfo $ "initializing device at path " <> device_
|
||||||
initDevice state handler device client
|
initDevice handler device client
|
||||||
Nothing -> logError $ "could not initialize device at path " <> device_
|
Nothing -> logError $ "could not initialize device at path " <> device_
|
||||||
where
|
where
|
||||||
device_ = displayWrapQuote $ displayObjectPath device
|
device_ = displayWrapQuote $ displayObjectPath device
|
||||||
|
|
||||||
initDevice
|
initDevice :: SignalHandler -> ObjectPath -> SysClient -> BTIO ()
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
initDevice sh device sys = do
|
||||||
=> MutableBtState
|
|
||||||
-> SignalHandler
|
|
||||||
-> ObjectPath
|
|
||||||
-> SysClient
|
|
||||||
-> m ()
|
|
||||||
initDevice state sh device sys = do
|
|
||||||
reply <- callGetConnected device sys
|
reply <- callGetConnected device sys
|
||||||
void $
|
void $
|
||||||
insertDevice state device $
|
insertDevice device $
|
||||||
BTDevice
|
BTDevice
|
||||||
{ btDevConnected = fromVariant =<< listToMaybe reply
|
{ btDevConnected = fromVariant =<< listToMaybe reply
|
||||||
, btDevSigHandler = sh
|
, btDevSigHandler = sh
|
||||||
}
|
}
|
||||||
|
|
||||||
addDeviceListener
|
addDeviceListener :: BTIO () -> ObjectPath -> SysClient -> BTIO (Maybe SignalHandler)
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
addDeviceListener dpy device sys = do
|
||||||
=> MutableBtState
|
|
||||||
-> m ()
|
|
||||||
-> ObjectPath
|
|
||||||
-> SysClient
|
|
||||||
-> m (Maybe SignalHandler)
|
|
||||||
addDeviceListener state dpy device sys = do
|
|
||||||
withBTPropertyRule sys device procMatch devInterface devConnected
|
withBTPropertyRule sys device procMatch devInterface devConnected
|
||||||
where
|
where
|
||||||
procMatch c = updateDevice state device c >> dpy
|
procMatch c = updateDevice device c >> dpy
|
||||||
|
|
||||||
callGetConnected
|
callGetConnected
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
|
@ -358,40 +333,32 @@ callGetConnected p =
|
||||||
callPropertyGet btBus p devInterface $
|
callPropertyGet btBus p devInterface $
|
||||||
memberName_ (T.unpack devConnected)
|
memberName_ (T.unpack devConnected)
|
||||||
|
|
||||||
insertDevice
|
insertDevice :: ObjectPath -> BTDevice -> BTIO Bool
|
||||||
:: MonadUnliftIO m
|
insertDevice device dev = do
|
||||||
=> MutableBtState
|
m <- asks btState
|
||||||
-> ObjectPath
|
modifyMVar m $ \s -> do
|
||||||
-> BTDevice
|
|
||||||
-> m Bool
|
|
||||||
insertDevice m device dev = modifyMVar m $ \s -> do
|
|
||||||
let new = M.insert device dev $ btDevices s
|
let new = M.insert device dev $ btDevices s
|
||||||
return (s {btDevices = new}, anyDevicesConnected new)
|
return (s {btDevices = new}, anyDevicesConnected new)
|
||||||
|
|
||||||
updateDevice
|
updateDevice :: ObjectPath -> Maybe Bool -> BTIO Bool
|
||||||
:: MonadUnliftIO m
|
updateDevice device status = do
|
||||||
=> MutableBtState
|
m <- asks btState
|
||||||
-> ObjectPath
|
modifyMVar m $ \s -> do
|
||||||
-> Maybe Bool
|
|
||||||
-> m Bool
|
|
||||||
updateDevice m device status = modifyMVar m $ \s -> do
|
|
||||||
let new = M.update (\d -> Just d {btDevConnected = status}) device $ btDevices s
|
let new = M.update (\d -> Just d {btDevConnected = status}) device $ btDevices s
|
||||||
return (s {btDevices = new}, anyDevicesConnected new)
|
return (s {btDevices = new}, anyDevicesConnected new)
|
||||||
|
|
||||||
anyDevicesConnected :: ConnectedDevices -> Bool
|
anyDevicesConnected :: ConnectedDevices -> Bool
|
||||||
anyDevicesConnected = or . mapMaybe btDevConnected . M.elems
|
anyDevicesConnected = or . mapMaybe btDevConnected . M.elems
|
||||||
|
|
||||||
removeDevice
|
removeDevice :: ObjectPath -> BTIO (Maybe BTDevice)
|
||||||
:: MonadUnliftIO m
|
removeDevice device = do
|
||||||
=> MutableBtState
|
m <- asks btState
|
||||||
-> ObjectPath
|
modifyMVar m $ \s -> do
|
||||||
-> m (Maybe BTDevice)
|
|
||||||
removeDevice m device = modifyMVar m $ \s -> do
|
|
||||||
let devs = btDevices s
|
let devs = btDevices s
|
||||||
return (s {btDevices = M.delete device devs}, M.lookup device devs)
|
return (s {btDevices = M.delete device devs}, M.lookup device devs)
|
||||||
|
|
||||||
readDevices :: MonadUnliftIO m => MutableBtState -> m ConnectedDevices
|
readDevices :: BTIO ConnectedDevices
|
||||||
readDevices = fmap btDevices . readMVar
|
readDevices = fmap btDevices $ readMVar =<< asks btState
|
||||||
|
|
||||||
devInterface :: InterfaceName
|
devInterface :: InterfaceName
|
||||||
devInterface = interfaceName_ "org.bluez.Device1"
|
devInterface = interfaceName_ "org.bluez.Device1"
|
||||||
|
|
Loading…
Reference in New Issue