ENH show VPN interface names
This commit is contained in:
parent
770f1dc1dd
commit
250d5c5eed
|
@ -423,7 +423,7 @@ vpnCmd :: Fontifier -> CmdSpec
|
|||
vpnCmd fontify =
|
||||
CmdSpec
|
||||
{ csAlias = vpnAlias
|
||||
, csRunnable = Run $ VPN (fontify IconMedium "\xf023" "VPN", colors)
|
||||
, csRunnable = Run $ VPN (T.append (fontify IconMedium "\xf023" "VPN") " ", colors)
|
||||
}
|
||||
|
||||
btCmd :: Fontifier -> CmdSpec
|
||||
|
|
|
@ -17,7 +17,6 @@ import Data.Internal.DBus
|
|||
import Data.Internal.XIO
|
||||
import RIO
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.Set as S
|
||||
import qualified RIO.Text as T
|
||||
import XMonad.Internal.Command.Desktop
|
||||
import XMonad.Internal.DBus.Common
|
||||
|
@ -30,7 +29,7 @@ instance Exec VPN where
|
|||
alias (VPN _) = T.unpack vpnAlias
|
||||
start (VPN (text, colors)) cb =
|
||||
withDBusClientConnection cb (Just "vpn.log") $ \c -> do
|
||||
let dpy = displayMaybe cb iconFormatter . Just =<< readState
|
||||
let dpy = displayMaybe cb formatter . Just =<< readState
|
||||
s <- newEmptyMVar
|
||||
mapRIO (VEnv c s dpy) $ do
|
||||
initState
|
||||
|
@ -38,7 +37,9 @@ instance Exec VPN where
|
|||
vpnRemovedListener removedCallback
|
||||
dpy
|
||||
where
|
||||
iconFormatter b = return $ colorText colors b text
|
||||
formatter names = return $ case names of
|
||||
[] -> colorText colors False text
|
||||
xs -> T.append (colorText colors True text) $ T.intercalate "|" xs
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- VPN State
|
||||
|
@ -62,7 +63,7 @@ instance HasClient VEnv where
|
|||
|
||||
type VIO = RIO (VEnv SysClient)
|
||||
|
||||
type VPNState = S.Set ObjectPath
|
||||
type VPNState = M.Map ObjectPath T.Text
|
||||
|
||||
initState :: VIO ()
|
||||
initState = do
|
||||
|
@ -70,13 +71,23 @@ initState = do
|
|||
s <- asks vState
|
||||
putMVar s $ findTunnels ot
|
||||
|
||||
readState :: VIO Bool
|
||||
readState = fmap (not . null) . readMVar =<< asks vState
|
||||
readState :: VIO [T.Text]
|
||||
readState = M.elems <$> (readMVar =<< asks vState)
|
||||
|
||||
updateState :: (ObjectPath -> VPNState -> VPNState) -> ObjectPath -> VIO ()
|
||||
updateState f op = do
|
||||
-- updateState :: (ObjectPath -> VPNState -> VPNState) -> ObjectPath -> VIO ()
|
||||
-- updateState f op = do
|
||||
-- s <- asks vState
|
||||
-- modifyMVar_ s $ return . f op
|
||||
|
||||
insertState :: ObjectPath -> T.Text -> VIO ()
|
||||
insertState op name = do
|
||||
s <- asks vState
|
||||
modifyMVar_ s $ return . f op
|
||||
modifyMVar_ s $ return . M.insert op name
|
||||
|
||||
deleteState :: ObjectPath -> VIO ()
|
||||
deleteState op = do
|
||||
s <- asks vState
|
||||
modifyMVar_ s $ return . M.delete op
|
||||
|
||||
beforeDisplay :: VIO () -> VIO ()
|
||||
beforeDisplay f = f >> join (asks vDisplay)
|
||||
|
@ -95,7 +106,15 @@ getVPNObjectTree
|
|||
getVPNObjectTree = callGetManagedObjects vpnBus vpnPath
|
||||
|
||||
findTunnels :: ObjectTree -> VPNState
|
||||
findTunnels = S.fromList . M.keys . M.filter (elem vpnDeviceTun . M.keys)
|
||||
findTunnels = M.mapMaybe lookupVPNInterface
|
||||
|
||||
-- | For the interface map underneath a given object path, try to lookup a
|
||||
-- VPN interface, then lookup the ip link name from the parent interface
|
||||
lookupVPNInterface :: M.Map T.Text (M.Map T.Text Variant) -> Maybe T.Text
|
||||
lookupVPNInterface m
|
||||
| isJust $ M.lookup vpnDeviceTun m =
|
||||
fromVariant =<< M.lookup "Interface" =<< M.lookup vpnDeviceParent m
|
||||
| otherwise = Nothing
|
||||
|
||||
vpnAddedListener
|
||||
:: ( SafeClient c
|
||||
|
@ -122,32 +141,27 @@ vpnRemovedListener cb = void $ addInterfaceRemovedListener vpnBus vpnPath cb
|
|||
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))
|
||||
forM_ (fromVariant device) $ \d ->
|
||||
forM_ (lookupVPNInterface =<< fromVariant added) $
|
||||
insertState d
|
||||
addedCallback _ = return ()
|
||||
|
||||
removedCallback :: SignalCallback VIO
|
||||
removedCallback [device, interfaces] =
|
||||
beforeDisplay $
|
||||
updateDevice S.delete device $
|
||||
fromMaybe [] $
|
||||
fromVariant interfaces
|
||||
removedCallback [device, _] =
|
||||
beforeDisplay $ forM_ (fromVariant device) deleteState
|
||||
removedCallback _ = return ()
|
||||
|
||||
updateDevice
|
||||
:: (ObjectPath -> VPNState -> VPNState)
|
||||
-> Variant
|
||||
-> [T.Text]
|
||||
-> VIO ()
|
||||
updateDevice f device interfaces =
|
||||
when (vpnDeviceTun `elem` interfaces) $
|
||||
forM_ d $
|
||||
updateState f
|
||||
where
|
||||
d = fromVariant device :: Maybe ObjectPath
|
||||
-- updateDevice
|
||||
-- :: (ObjectPath -> VPNState -> VPNState)
|
||||
-- -> Variant
|
||||
-- -> [T.Text]
|
||||
-- -> VIO ()
|
||||
-- updateDevice f device interfaces =
|
||||
-- when (vpnDeviceTun `elem` interfaces) $
|
||||
-- forM_ d $
|
||||
-- updateState f
|
||||
-- where
|
||||
-- d = fromVariant device :: Maybe ObjectPath
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- DBus Interface
|
||||
|
@ -161,6 +175,9 @@ vpnPath = objectPath_ "/org/freedesktop"
|
|||
vpnDeviceTun :: T.Text
|
||||
vpnDeviceTun = "org.freedesktop.NetworkManager.Device.Tun"
|
||||
|
||||
vpnDeviceParent :: T.Text
|
||||
vpnDeviceParent = "org.freedesktop.NetworkManager.Device"
|
||||
|
||||
vpnAlias :: T.Text
|
||||
vpnAlias = "vpn"
|
||||
|
||||
|
|
Loading…
Reference in New Issue