ENH use rio for vpn
This commit is contained in:
parent
c29a43a024
commit
27b32fb03e
|
@ -162,6 +162,9 @@ modifyState f = do
|
||||||
m <- asks btState
|
m <- asks btState
|
||||||
modifyMVar m f
|
modifyMVar m f
|
||||||
|
|
||||||
|
beforeDisplay :: BTIO () -> BTIO ()
|
||||||
|
beforeDisplay f = f >> join (asks btDisplay)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Object manager
|
-- Object manager
|
||||||
|
|
||||||
|
@ -211,8 +214,7 @@ addDeviceRemovedListener adapter sys =
|
||||||
|
|
||||||
pathCallback :: ObjectPath -> (ObjectPath -> BTIO ()) -> SignalCallback BTIO
|
pathCallback :: ObjectPath -> (ObjectPath -> BTIO ()) -> SignalCallback BTIO
|
||||||
pathCallback adapter f [device, _] = forM_ (fromVariant device) $ \d -> do
|
pathCallback adapter f [device, _] = forM_ (fromVariant device) $ \d -> do
|
||||||
dpy <- asks btDisplay
|
when (adaptorHasDevice adapter d) $ beforeDisplay $ f d
|
||||||
when (adaptorHasDevice adapter d) $ f d >> dpy
|
|
||||||
pathCallback _ _ _ = return ()
|
pathCallback _ _ _ = return ()
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
@ -261,10 +263,10 @@ withBTPropertyRule cl path update iface prop = do
|
||||||
matchConnected = matchPropertyChanged iface prop
|
matchConnected = matchPropertyChanged iface prop
|
||||||
|
|
||||||
addAdaptorListener :: ObjectPath -> SysClient -> BTIO (Maybe SignalHandler)
|
addAdaptorListener :: ObjectPath -> SysClient -> BTIO (Maybe SignalHandler)
|
||||||
addAdaptorListener adaptor sys = do
|
addAdaptorListener adaptor sys =
|
||||||
dpy <- asks btDisplay
|
|
||||||
let procMatch b = putPowered b >> dpy
|
|
||||||
withBTPropertyRule sys adaptor procMatch adapterInterface adaptorPowered
|
withBTPropertyRule sys adaptor procMatch adapterInterface adaptorPowered
|
||||||
|
where
|
||||||
|
procMatch = beforeDisplay . putPowered
|
||||||
|
|
||||||
callGetPowered
|
callGetPowered
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
|
@ -313,10 +315,10 @@ initDevice sh device sys = do
|
||||||
}
|
}
|
||||||
|
|
||||||
addDeviceListener :: ObjectPath -> SysClient -> BTIO (Maybe SignalHandler)
|
addDeviceListener :: ObjectPath -> SysClient -> BTIO (Maybe SignalHandler)
|
||||||
addDeviceListener device sys = do
|
addDeviceListener device sys =
|
||||||
dpy <- asks btDisplay
|
|
||||||
let procMatch c = updateDevice device c >> dpy
|
|
||||||
withBTPropertyRule sys device procMatch devInterface devConnected
|
withBTPropertyRule sys device procMatch devInterface devConnected
|
||||||
|
where
|
||||||
|
procMatch = beforeDisplay . void . updateDevice device
|
||||||
|
|
||||||
callGetConnected
|
callGetConnected
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
|
|
|
@ -33,11 +33,11 @@ instance Exec VPN where
|
||||||
start (VPN (text, colors)) cb =
|
start (VPN (text, colors)) cb =
|
||||||
withDBusClientConnection cb "VPN" $ \c -> do
|
withDBusClientConnection cb "VPN" $ \c -> do
|
||||||
state <- initState c
|
state <- initState c
|
||||||
let dpy = displayMaybe cb iconFormatter . Just =<< readState state
|
let dpy = displayMaybe cb iconFormatter . Just =<< readState
|
||||||
let signalCallback' f = f state dpy
|
mapRIO (VEnv state dpy) $ do
|
||||||
vpnAddedListener (signalCallback' addedCallback) c
|
vpnAddedListener addedCallback c
|
||||||
vpnRemovedListener (signalCallback' removedCallback) c
|
vpnRemovedListener removedCallback c
|
||||||
dpy
|
dpy
|
||||||
where
|
where
|
||||||
iconFormatter b = return $ colorText colors b text
|
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
|
-- 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.
|
-- 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 VPNState = S.Set ObjectPath
|
||||||
|
|
||||||
type MutableVPNState = MVar VPNState
|
type MutableVPNState = MVar VPNState
|
||||||
|
@ -60,16 +71,16 @@ initState client = do
|
||||||
ot <- getVPNObjectTree client
|
ot <- getVPNObjectTree client
|
||||||
newMVar $ findTunnels ot
|
newMVar $ findTunnels ot
|
||||||
|
|
||||||
readState :: MonadUnliftIO m => MutableVPNState -> m Bool
|
readState :: VIO Bool
|
||||||
readState = fmap (not . null) . readMVar
|
readState = fmap (not . null) . readMVar =<< asks vState
|
||||||
|
|
||||||
updateState
|
updateState :: (ObjectPath -> VPNState -> VPNState) -> ObjectPath -> VIO ()
|
||||||
:: MonadUnliftIO m
|
updateState f op = do
|
||||||
=> (ObjectPath -> VPNState -> VPNState)
|
s <- asks vState
|
||||||
-> MutableVPNState
|
modifyMVar_ s $ return . f op
|
||||||
-> ObjectPath
|
|
||||||
-> m ()
|
beforeDisplay :: VIO () -> VIO ()
|
||||||
updateState f state op = modifyMVar_ state $ return . f op
|
beforeDisplay f = f >> join (asks vDisplay)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Tunnel Device Detection
|
-- Tunnel Device Detection
|
||||||
|
@ -97,32 +108,33 @@ vpnRemovedListener
|
||||||
-> m ()
|
-> m ()
|
||||||
vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb
|
vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb
|
||||||
|
|
||||||
addedCallback :: MonadUnliftIO m => MutableVPNState -> m () -> SignalCallback m
|
addedCallback :: SignalCallback VIO
|
||||||
addedCallback state dpy [device, added] = update >> dpy
|
addedCallback [device, added] =
|
||||||
|
beforeDisplay $
|
||||||
|
updateDevice S.insert device $
|
||||||
|
M.keys $
|
||||||
|
fromMaybe M.empty added'
|
||||||
where
|
where
|
||||||
added' = fromVariant added :: Maybe (M.Map T.Text (M.Map T.Text Variant))
|
added' = fromVariant added :: Maybe (M.Map T.Text (M.Map T.Text Variant))
|
||||||
is = M.keys $ fromMaybe M.empty added'
|
addedCallback _ = return ()
|
||||||
update = updateDevice S.insert state device is
|
|
||||||
addedCallback _ _ _ = return ()
|
|
||||||
|
|
||||||
removedCallback :: MonadUnliftIO m => MutableVPNState -> m () -> SignalCallback m
|
removedCallback :: SignalCallback VIO
|
||||||
removedCallback state dpy [device, interfaces] = update >> dpy
|
removedCallback [device, interfaces] =
|
||||||
where
|
beforeDisplay $
|
||||||
is = fromMaybe [] $ fromVariant interfaces :: [T.Text]
|
updateDevice S.delete device $
|
||||||
update = updateDevice S.delete state device is
|
fromMaybe [] $
|
||||||
removedCallback _ _ _ = return ()
|
fromVariant interfaces
|
||||||
|
removedCallback _ = return ()
|
||||||
|
|
||||||
updateDevice
|
updateDevice
|
||||||
:: MonadUnliftIO m
|
:: (ObjectPath -> VPNState -> VPNState)
|
||||||
=> (ObjectPath -> VPNState -> VPNState)
|
|
||||||
-> MutableVPNState
|
|
||||||
-> Variant
|
-> Variant
|
||||||
-> [T.Text]
|
-> [T.Text]
|
||||||
-> m ()
|
-> VIO ()
|
||||||
updateDevice f state device interfaces =
|
updateDevice f device interfaces =
|
||||||
when (vpnDeviceTun `elem` interfaces) $
|
when (vpnDeviceTun `elem` interfaces) $
|
||||||
forM_ d $
|
forM_ d $
|
||||||
updateState f state
|
updateState f
|
||||||
where
|
where
|
||||||
d = fromVariant device :: Maybe ObjectPath
|
d = fromVariant device :: Maybe ObjectPath
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue