ENH use rio for vpn

This commit is contained in:
Nathan Dwarshuis 2023-01-02 10:33:04 -05:00
parent c29a43a024
commit 27b32fb03e
2 changed files with 53 additions and 39 deletions

View File

@ -162,6 +162,9 @@ modifyState f = do
m <- asks btState
modifyMVar m f
beforeDisplay :: BTIO () -> BTIO ()
beforeDisplay f = f >> join (asks btDisplay)
--------------------------------------------------------------------------------
-- Object manager
@ -211,8 +214,7 @@ addDeviceRemovedListener adapter sys =
pathCallback :: ObjectPath -> (ObjectPath -> BTIO ()) -> SignalCallback BTIO
pathCallback adapter f [device, _] = forM_ (fromVariant device) $ \d -> do
dpy <- asks btDisplay
when (adaptorHasDevice adapter d) $ f d >> dpy
when (adaptorHasDevice adapter d) $ beforeDisplay $ f d
pathCallback _ _ _ = return ()
--------------------------------------------------------------------------------
@ -261,10 +263,10 @@ withBTPropertyRule cl path update iface prop = do
matchConnected = matchPropertyChanged iface prop
addAdaptorListener :: ObjectPath -> SysClient -> BTIO (Maybe SignalHandler)
addAdaptorListener adaptor sys = do
dpy <- asks btDisplay
let procMatch b = putPowered b >> dpy
addAdaptorListener adaptor sys =
withBTPropertyRule sys adaptor procMatch adapterInterface adaptorPowered
where
procMatch = beforeDisplay . putPowered
callGetPowered
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
@ -313,10 +315,10 @@ initDevice sh device sys = do
}
addDeviceListener :: ObjectPath -> SysClient -> BTIO (Maybe SignalHandler)
addDeviceListener device sys = do
dpy <- asks btDisplay
let procMatch c = updateDevice device c >> dpy
addDeviceListener device sys =
withBTPropertyRule sys device procMatch devInterface devConnected
where
procMatch = beforeDisplay . void . updateDevice device
callGetConnected
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)

View File

@ -33,11 +33,11 @@ instance Exec VPN where
start (VPN (text, colors)) cb =
withDBusClientConnection cb "VPN" $ \c -> do
state <- initState c
let dpy = displayMaybe cb iconFormatter . Just =<< readState state
let signalCallback' f = f state dpy
vpnAddedListener (signalCallback' addedCallback) c
vpnRemovedListener (signalCallback' removedCallback) c
dpy
let dpy = displayMaybe cb iconFormatter . Just =<< readState
mapRIO (VEnv state dpy) $ do
vpnAddedListener addedCallback c
vpnRemovedListener removedCallback c
dpy
where
iconFormatter b = return $ colorText colors b text
@ -48,6 +48,17 @@ instance Exec VPN where
-- this will be a null or singleton set, but this setup could handle the edge
-- case of multiple VPNs being active at once without puking.
data VEnv = VEnv
{ vState :: !MutableVPNState
, vDisplay :: !(VIO ())
, vEnv :: !SimpleApp
}
instance HasLogFunc VEnv where
logFuncL = lens vEnv (\x y -> x {vEnv = y}) . logFuncL
type VIO = RIO VEnv
type VPNState = S.Set ObjectPath
type MutableVPNState = MVar VPNState
@ -60,16 +71,16 @@ initState client = do
ot <- getVPNObjectTree client
newMVar $ findTunnels ot
readState :: MonadUnliftIO m => MutableVPNState -> m Bool
readState = fmap (not . null) . readMVar
readState :: VIO Bool
readState = fmap (not . null) . readMVar =<< asks vState
updateState
:: MonadUnliftIO m
=> (ObjectPath -> VPNState -> VPNState)
-> MutableVPNState
-> ObjectPath
-> m ()
updateState f state op = modifyMVar_ state $ return . f op
updateState :: (ObjectPath -> VPNState -> VPNState) -> ObjectPath -> VIO ()
updateState f op = do
s <- asks vState
modifyMVar_ s $ return . f op
beforeDisplay :: VIO () -> VIO ()
beforeDisplay f = f >> join (asks vDisplay)
--------------------------------------------------------------------------------
-- Tunnel Device Detection
@ -97,32 +108,33 @@ vpnRemovedListener
-> m ()
vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb
addedCallback :: MonadUnliftIO m => MutableVPNState -> m () -> SignalCallback m
addedCallback state dpy [device, added] = update >> dpy
addedCallback :: SignalCallback VIO
addedCallback [device, added] =
beforeDisplay $
updateDevice S.insert device $
M.keys $
fromMaybe M.empty added'
where
added' = fromVariant added :: Maybe (M.Map T.Text (M.Map T.Text Variant))
is = M.keys $ fromMaybe M.empty added'
update = updateDevice S.insert state device is
addedCallback _ _ _ = return ()
addedCallback _ = return ()
removedCallback :: MonadUnliftIO m => MutableVPNState -> m () -> SignalCallback m
removedCallback state dpy [device, interfaces] = update >> dpy
where
is = fromMaybe [] $ fromVariant interfaces :: [T.Text]
update = updateDevice S.delete state device is
removedCallback _ _ _ = return ()
removedCallback :: SignalCallback VIO
removedCallback [device, interfaces] =
beforeDisplay $
updateDevice S.delete device $
fromMaybe [] $
fromVariant interfaces
removedCallback _ = return ()
updateDevice
:: MonadUnliftIO m
=> (ObjectPath -> VPNState -> VPNState)
-> MutableVPNState
:: (ObjectPath -> VPNState -> VPNState)
-> Variant
-> [T.Text]
-> m ()
updateDevice f state device interfaces =
-> VIO ()
updateDevice f device interfaces =
when (vpnDeviceTun `elem` interfaces) $
forM_ d $
updateState f state
updateState f
where
d = fromVariant device :: Maybe ObjectPath