REF use submonad for bluetooth state

This commit is contained in:
Nathan Dwarshuis 2023-01-01 23:03:31 -05:00
parent 9d7ca49357
commit 37f607d817
1 changed files with 84 additions and 117 deletions

View File

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