ENH use rio for vpn
This commit is contained in:
parent
c29a43a024
commit
27b32fb03e
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
Loading…
Reference in New Issue