ENH generalize bluetooth
This commit is contained in:
parent
6738f8a4c7
commit
c394a65523
|
@ -69,7 +69,13 @@ instance Exec Bluetooth where
|
||||||
start (Bluetooth icons colors) cb =
|
start (Bluetooth icons colors) cb =
|
||||||
withDBusClientConnection cb $ startAdapter icons colors cb
|
withDBusClientConnection cb $ startAdapter icons colors cb
|
||||||
|
|
||||||
startAdapter :: Icons -> Colors -> Callback -> SysClient -> IO ()
|
startAdapter
|
||||||
|
:: MonadUnliftIO m
|
||||||
|
=> Icons
|
||||||
|
-> Colors
|
||||||
|
-> Callback
|
||||||
|
-> SysClient
|
||||||
|
-> m ()
|
||||||
startAdapter is cs cb cl = do
|
startAdapter is cs cb cl = do
|
||||||
ot <- getBtObjectTree cl
|
ot <- getBtObjectTree cl
|
||||||
state <- newMVar emptyState
|
state <- newMVar emptyState
|
||||||
|
@ -97,9 +103,9 @@ type IconFormatter = (Maybe Bool -> Bool -> T.Text)
|
||||||
|
|
||||||
type Icons = (T.Text, T.Text)
|
type Icons = (T.Text, T.Text)
|
||||||
|
|
||||||
displayIcon :: Callback -> IconFormatter -> MutableBtState -> IO ()
|
displayIcon :: MonadUnliftIO m => Callback -> IconFormatter -> MutableBtState -> m ()
|
||||||
displayIcon callback formatter =
|
displayIcon callback formatter =
|
||||||
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
|
||||||
|
@ -137,7 +143,7 @@ emptyState =
|
||||||
, btPowered = Nothing
|
, btPowered = Nothing
|
||||||
}
|
}
|
||||||
|
|
||||||
readState :: MutableBtState -> IO (Maybe Bool, Bool)
|
readState :: MonadUnliftIO m => MutableBtState -> m (Maybe Bool, Bool)
|
||||||
readState state = do
|
readState state = do
|
||||||
p <- readPowered state
|
p <- readPowered state
|
||||||
c <- readDevices state
|
c <- readDevices state
|
||||||
|
@ -160,7 +166,7 @@ adaptorHasDevice adaptor device = case splitPath device of
|
||||||
splitPath :: ObjectPath -> [T.Text]
|
splitPath :: ObjectPath -> [T.Text]
|
||||||
splitPath = fmap T.pack . splitOn "/" . dropWhile (== '/') . formatObjectPath
|
splitPath = fmap T.pack . splitOn "/" . dropWhile (== '/') . formatObjectPath
|
||||||
|
|
||||||
getBtObjectTree :: SysClient -> IO ObjectTree
|
getBtObjectTree :: MonadUnliftIO m => SysClient -> m ObjectTree
|
||||||
getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath
|
getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath
|
||||||
|
|
||||||
btOMPath :: ObjectPath
|
btOMPath :: ObjectPath
|
||||||
|
@ -169,50 +175,72 @@ btOMPath = objectPath_ "/"
|
||||||
addBtOMListener :: MonadUnliftIO m => SignalCallback m -> SysClient -> m ()
|
addBtOMListener :: MonadUnliftIO m => SignalCallback m -> SysClient -> m ()
|
||||||
addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc
|
addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc
|
||||||
|
|
||||||
addDeviceAddedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
|
addDeviceAddedListener
|
||||||
|
:: MonadUnliftIO m
|
||||||
|
=> MutableBtState
|
||||||
|
-> m ()
|
||||||
|
-> ObjectPath
|
||||||
|
-> SysClient
|
||||||
|
-> m ()
|
||||||
addDeviceAddedListener state dpy adapter client =
|
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 state dpy d client
|
||||||
|
|
||||||
addDeviceRemovedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
|
addDeviceRemovedListener
|
||||||
|
:: (MonadUnliftIO m)
|
||||||
|
=> MutableBtState
|
||||||
|
-> m ()
|
||||||
|
-> ObjectPath
|
||||||
|
-> SysClient
|
||||||
|
-> m ()
|
||||||
addDeviceRemovedListener state dpy adapter sys =
|
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 state d
|
||||||
forM_ old $ removeMatch (toClient sys) . btDevSigHandler
|
forM_ old $ liftIO . removeMatch (toClient sys) . btDevSigHandler
|
||||||
|
|
||||||
pathCallback :: MonadUnliftIO m => ObjectPath -> IO () -> (ObjectPath -> IO ()) -> SignalCallback m
|
pathCallback :: MonadUnliftIO m => ObjectPath -> m () -> (ObjectPath -> m ()) -> SignalCallback m
|
||||||
pathCallback adapter dpy f [device, _] = liftIO $ forM_ (fromVariant device) $ \d ->
|
pathCallback adapter dpy f [device, _] = forM_ (fromVariant device) $ \d ->
|
||||||
when (adaptorHasDevice adapter d) $ f d >> dpy
|
when (adaptorHasDevice adapter d) $ f d >> dpy
|
||||||
pathCallback _ _ _ _ = return ()
|
pathCallback _ _ _ _ = return ()
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Adapter
|
-- Adapter
|
||||||
|
|
||||||
initAdapter :: MutableBtState -> ObjectPath -> SysClient -> IO ()
|
initAdapter
|
||||||
|
:: (MonadUnliftIO m)
|
||||||
|
=> MutableBtState
|
||||||
|
-> ObjectPath
|
||||||
|
-> SysClient
|
||||||
|
-> m ()
|
||||||
initAdapter state adapter client = do
|
initAdapter state adapter client = do
|
||||||
reply <- callGetPowered adapter client
|
reply <- callGetPowered adapter client
|
||||||
putPowered state $ fromSingletonVariant reply
|
putPowered state $ fromSingletonVariant reply
|
||||||
|
|
||||||
matchBTProperty :: SysClient -> ObjectPath -> IO (Maybe MatchRule)
|
matchBTProperty
|
||||||
|
:: (MonadUnliftIO m)
|
||||||
|
=> SysClient
|
||||||
|
-> ObjectPath
|
||||||
|
-> m (Maybe MatchRule)
|
||||||
matchBTProperty sys p = matchPropertyFull sys btBus (Just p)
|
matchBTProperty sys p = matchPropertyFull sys btBus (Just p)
|
||||||
|
|
||||||
addAdaptorListener
|
addAdaptorListener
|
||||||
:: MutableBtState
|
:: MonadUnliftIO m
|
||||||
-> IO ()
|
=> MutableBtState
|
||||||
|
-> m ()
|
||||||
-> ObjectPath
|
-> ObjectPath
|
||||||
-> SysClient
|
-> SysClient
|
||||||
-> IO (Maybe SignalHandler)
|
-> m (Maybe SignalHandler)
|
||||||
addAdaptorListener state dpy adaptor sys = do
|
addAdaptorListener state dpy adaptor sys = do
|
||||||
rule <- matchBTProperty sys adaptor
|
rule <- matchBTProperty sys adaptor
|
||||||
forM rule $ \r -> addMatchCallback r (procMatch . matchPowered) sys
|
forM rule $ \r -> addMatchCallback r (procMatch . matchPowered) sys
|
||||||
where
|
where
|
||||||
procMatch = withSignalMatch $ \b -> putPowered state b >> dpy
|
procMatch = withSignalMatch $ \b -> putPowered state b >> dpy
|
||||||
|
|
||||||
callGetPowered :: ObjectPath -> SysClient -> IO [Variant]
|
callGetPowered :: MonadUnliftIO m => ObjectPath -> SysClient -> m [Variant]
|
||||||
callGetPowered adapter =
|
callGetPowered adapter =
|
||||||
callPropertyGet btBus adapter adapterInterface $
|
callPropertyGet btBus adapter adapterInterface $
|
||||||
memberName_ $
|
memberName_ $
|
||||||
|
@ -221,10 +249,10 @@ callGetPowered adapter =
|
||||||
matchPowered :: [Variant] -> SignalMatch Bool
|
matchPowered :: [Variant] -> SignalMatch Bool
|
||||||
matchPowered = matchPropertyChanged adapterInterface adaptorPowered
|
matchPowered = matchPropertyChanged adapterInterface adaptorPowered
|
||||||
|
|
||||||
putPowered :: MutableBtState -> Maybe Bool -> IO ()
|
putPowered :: MonadUnliftIO m => MutableBtState -> Maybe Bool -> m ()
|
||||||
putPowered m ds = modifyMVar_ m (\s -> return s {btPowered = ds})
|
putPowered m ds = modifyMVar_ m (\s -> return s {btPowered = ds})
|
||||||
|
|
||||||
readPowered :: MutableBtState -> IO (Maybe Bool)
|
readPowered :: MonadUnliftIO m => MutableBtState -> m (Maybe Bool)
|
||||||
readPowered = fmap btPowered . readMVar
|
readPowered = fmap btPowered . readMVar
|
||||||
|
|
||||||
adapterInterface :: InterfaceName
|
adapterInterface :: InterfaceName
|
||||||
|
@ -236,13 +264,25 @@ adaptorPowered = "Powered"
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Devices
|
-- Devices
|
||||||
|
|
||||||
addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
|
addAndInitDevice
|
||||||
|
:: MonadUnliftIO m
|
||||||
|
=> MutableBtState
|
||||||
|
-> m ()
|
||||||
|
-> ObjectPath
|
||||||
|
-> SysClient
|
||||||
|
-> m ()
|
||||||
addAndInitDevice state dpy device client = do
|
addAndInitDevice state dpy device client = do
|
||||||
sh <- addDeviceListener state dpy device client
|
sh <- addDeviceListener state dpy device client
|
||||||
-- TODO add some intelligent error messages here
|
-- TODO add some intelligent error messages here
|
||||||
forM_ sh $ \s -> initDevice state s device client
|
forM_ sh $ \s -> initDevice state s device client
|
||||||
|
|
||||||
initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> SysClient -> IO ()
|
initDevice
|
||||||
|
:: MonadUnliftIO m
|
||||||
|
=> MutableBtState
|
||||||
|
-> SignalHandler
|
||||||
|
-> ObjectPath
|
||||||
|
-> SysClient
|
||||||
|
-> m ()
|
||||||
initDevice state sh device sys = do
|
initDevice state sh device sys = do
|
||||||
reply <- callGetConnected device sys
|
reply <- callGetConnected device sys
|
||||||
void $
|
void $
|
||||||
|
@ -253,11 +293,12 @@ initDevice state sh device sys = do
|
||||||
}
|
}
|
||||||
|
|
||||||
addDeviceListener
|
addDeviceListener
|
||||||
:: MutableBtState
|
:: MonadUnliftIO m
|
||||||
-> IO ()
|
=> MutableBtState
|
||||||
|
-> m ()
|
||||||
-> ObjectPath
|
-> ObjectPath
|
||||||
-> SysClient
|
-> SysClient
|
||||||
-> IO (Maybe SignalHandler)
|
-> m (Maybe SignalHandler)
|
||||||
addDeviceListener state dpy device sys = do
|
addDeviceListener state dpy device sys = do
|
||||||
rule <- matchBTProperty sys device
|
rule <- matchBTProperty sys device
|
||||||
forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) sys
|
forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) sys
|
||||||
|
@ -267,17 +308,27 @@ addDeviceListener state dpy device sys = do
|
||||||
matchConnected :: [Variant] -> SignalMatch Bool
|
matchConnected :: [Variant] -> SignalMatch Bool
|
||||||
matchConnected = matchPropertyChanged devInterface devConnected
|
matchConnected = matchPropertyChanged devInterface devConnected
|
||||||
|
|
||||||
callGetConnected :: ObjectPath -> SysClient -> IO [Variant]
|
callGetConnected :: MonadUnliftIO m => ObjectPath -> SysClient -> m [Variant]
|
||||||
callGetConnected p =
|
callGetConnected p =
|
||||||
callPropertyGet btBus p devInterface $
|
callPropertyGet btBus p devInterface $
|
||||||
memberName_ (T.unpack devConnected)
|
memberName_ (T.unpack devConnected)
|
||||||
|
|
||||||
insertDevice :: MutableBtState -> ObjectPath -> BTDevice -> IO Bool
|
insertDevice
|
||||||
|
:: MonadUnliftIO m
|
||||||
|
=> MutableBtState
|
||||||
|
-> ObjectPath
|
||||||
|
-> BTDevice
|
||||||
|
-> m Bool
|
||||||
insertDevice m device dev = modifyMVar m $ \s -> do
|
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 :: MutableBtState -> ObjectPath -> Maybe Bool -> IO Bool
|
updateDevice
|
||||||
|
:: MonadUnliftIO m
|
||||||
|
=> MutableBtState
|
||||||
|
-> ObjectPath
|
||||||
|
-> Maybe Bool
|
||||||
|
-> m Bool
|
||||||
updateDevice m device status = modifyMVar m $ \s -> do
|
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)
|
||||||
|
@ -285,12 +336,16 @@ updateDevice m device status = modifyMVar m $ \s -> do
|
||||||
anyDevicesConnected :: ConnectedDevices -> Bool
|
anyDevicesConnected :: ConnectedDevices -> Bool
|
||||||
anyDevicesConnected = or . mapMaybe btDevConnected . M.elems
|
anyDevicesConnected = or . mapMaybe btDevConnected . M.elems
|
||||||
|
|
||||||
removeDevice :: MutableBtState -> ObjectPath -> IO (Maybe BTDevice)
|
removeDevice
|
||||||
|
:: MonadUnliftIO m
|
||||||
|
=> MutableBtState
|
||||||
|
-> ObjectPath
|
||||||
|
-> m (Maybe BTDevice)
|
||||||
removeDevice m device = modifyMVar m $ \s -> do
|
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 :: MutableBtState -> IO ConnectedDevices
|
readDevices :: MonadUnliftIO m => MutableBtState -> m ConnectedDevices
|
||||||
readDevices = fmap btDevices . readMVar
|
readDevices = fmap btDevices . readMVar
|
||||||
|
|
||||||
devInterface :: InterfaceName
|
devInterface :: InterfaceName
|
||||||
|
|
Loading…
Reference in New Issue