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
|
||||
|
||||
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
|
||||
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 state adapter cl
|
||||
void $ addAdaptorListener state dpy adapter cl
|
||||
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 state dpy adapter cl
|
||||
addDeviceRemovedListener state dpy adapter cl
|
||||
forM_ devices $ \d -> addAndInitDevice state dpy d cl
|
||||
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
|
||||
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
|
||||
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
|
||||
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"
|
||||
|
|
|
|||
Loading…
Reference in New Issue