ENH use active connection plugin for both networkmanager and vpn connections

This commit is contained in:
Nathan Dwarshuis 2023-09-30 23:52:52 -04:00
parent f814ac9217
commit 2f6eeb5cdb
3 changed files with 42 additions and 197 deletions

View File

@ -28,10 +28,10 @@ import Xmobar hiding
( iconOffset ( iconOffset
, run , run
) )
import Xmobar.Plugins.ActiveConnection
import Xmobar.Plugins.Bluetooth import Xmobar.Plugins.Bluetooth
import Xmobar.Plugins.ClevoKeyboard import Xmobar.Plugins.ClevoKeyboard
import Xmobar.Plugins.Common import Xmobar.Plugins.Common
import Xmobar.Plugins.Device
import Xmobar.Plugins.IntelBacklight import Xmobar.Plugins.IntelBacklight
import Xmobar.Plugins.Screensaver import Xmobar.Plugins.Screensaver
import Xmobar.Plugins.VPN import Xmobar.Plugins.VPN
@ -223,7 +223,7 @@ getEthernet :: Maybe SysClient -> BarFeature
getEthernet cl = iconDBus_ "ethernet status indicator" xpfEthernet root (Only_ devDep) getEthernet cl = iconDBus_ "ethernet status indicator" xpfEthernet root (Only_ devDep)
where where
root useIcon tree' = root useIcon tree' =
DBusRoot_ (const $ ethernetCmd useIcon ("vlan" :| ["802-3-ethernet"])) tree' cl DBusRoot_ (const $ ethernetCmd useIcon) tree' cl
getBattery :: BarFeature getBattery :: BarFeature
getBattery = iconIO_ "battery level indicator" xpfBattery root tree getBattery = iconIO_ "battery level indicator" xpfBattery root tree
@ -369,13 +369,19 @@ wirelessCmd iface =
, "<icon=wifi_%%.xpm/>" , "<icon=wifi_%%.xpm/>"
] ]
ethernetCmd :: Fontifier -> NE.NonEmpty T.Text -> CmdSpec ethernetCmd :: Fontifier -> CmdSpec
ethernetCmd fontify contypes = ethernetCmd = connCmd "\xf0e8" "ETH" ("vlan" :| ["802-3-ethernet"])
vpnCmd :: Fontifier -> CmdSpec
vpnCmd = connCmd "\xf023" "VPN" ("tun" :| [])
connCmd :: T.Text -> T.Text -> NE.NonEmpty T.Text -> Fontifier -> CmdSpec
connCmd icon abbr contypes fontify =
CmdSpec CmdSpec
{ csAlias = "connection" { csAlias = connAlias contypes
, csRunnable = , csRunnable =
Run $ Run $
Device (contypes, fontify IconMedium "\xf0e8" "ETH", colors) ActiveConnection (contypes, fontify IconMedium icon abbr, colors)
} }
batteryCmd :: Fontifier -> CmdSpec batteryCmd :: Fontifier -> CmdSpec
@ -411,13 +417,6 @@ batteryCmd fontify =
, fontify' "\xf1e6" "AC" , fontify' "\xf1e6" "AC"
] ]
vpnCmd :: Fontifier -> CmdSpec
vpnCmd fontify =
CmdSpec
{ csAlias = vpnAlias
, csRunnable = Run $ VPN (fontify IconMedium "\xf023" "VPN", colors)
}
btCmd :: Fontifier -> CmdSpec btCmd :: Fontifier -> CmdSpec
btCmd fontify = btCmd fontify =
CmdSpec CmdSpec

View File

@ -1,12 +1,19 @@
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Device plugin -- NetworkManager Connection plugin
-- --
-- Display different text depending on whether or not the interface has -- Show active connections of varying types.
-- connectivity --
-- This plugin exclusively monitors the */ActiveConnection/* paths in the
-- NetworkManager DBus path for state changes. It does not pin these to any
-- particular interface but instead looks at all connections equally and filters
-- based on their Type (ethernet, wifi, VPN, etc). For many use cases this will
-- track well enough with either one or a collection of similar interfaces (ie
-- all ethernet or all wifi).
module Xmobar.Plugins.Device module Xmobar.Plugins.ActiveConnection
( Device (..) ( ActiveConnection (..)
, devDep , devDep
, connAlias
) )
where where
@ -22,7 +29,9 @@ import XMonad.Internal.DBus.Common
import Xmobar import Xmobar
import Xmobar.Plugins.Common import Xmobar.Plugins.Common
newtype Device = Device (NE.NonEmpty T.Text, T.Text, Colors) deriving (Read, Show) newtype ActiveConnection
= ActiveConnection (NE.NonEmpty T.Text, T.Text, Colors)
deriving (Read, Show)
nmPath :: ObjectPath nmPath :: ObjectPath
nmPath = objectPath_ "/org/freedesktop/NetworkManager" nmPath = objectPath_ "/org/freedesktop/NetworkManager"
@ -128,22 +137,29 @@ initialState contypes =
readState :: EthIO [T.Text] readState :: EthIO [T.Text]
readState = M.elems <$> (readMVar =<< asks ethState) readState = M.elems <$> (readMVar =<< asks ethState)
instance Exec Device where connAlias :: NE.NonEmpty T.Text -> T.Text
alias (Device (_, _, _)) = "connection" connAlias = T.intercalate "_" . NE.toList
start (Device (contypes, text, colors)) cb =
instance Exec ActiveConnection where
alias (ActiveConnection (contypes, _, _)) = T.unpack $ connAlias contypes
start (ActiveConnection (contypes, text, colors)) cb =
withDBusClientConnection cb (Just "ethernet.log") $ \c -> do withDBusClientConnection cb (Just "ethernet.log") $ \c -> do
let dpy = displayMaybe cb formatter . Just =<< readState let dpy = displayMaybe cb formatter . Just =<< readState
i <- withDIO c $ initialState contypes i <- withDIO c $ initialState contypes
s <- newMVar i s <- newMVar i
mapRIO (EthEnv c s dpy) $ do let mapEnv c' = mapRIO (EthEnv c' s dpy)
addListener mapEnv c $ addListener mapEnv >> dpy
dpy
where where
formatter names = return $ case names of formatter names = return $ case names of
[] -> colorText colors False text [] -> colorText colors False text
xs -> T.unwords [T.intercalate "|" xs, colorText colors True text] xs -> T.unwords [T.intercalate "|" xs, colorText colors True text]
addListener = do addListener mapEnv = do
res <- matchSignalFull ethBus Nothing (Just nmActiveInterface) (Just stateChanged) res <- matchSignalFull ethBus Nothing (Just nmActiveInterface) (Just stateChanged)
case res of case res of
Just rule -> void $ addMatchCallbackSignal rule (testActiveType contypes)
Nothing -> logError "could not start listener" Nothing -> logError "could not start listener"
Just rule ->
void $
addMatchCallbackSignal rule $ \sig ->
withDBusClientConnection cb (Just "ethernet-cb.log") $ \c' ->
mapEnv c' $
testActiveType contypes sig

View File

@ -1,170 +0,0 @@
--------------------------------------------------------------------------------
-- VPN plugin
--
-- Use the networkmanager to detect when a VPN interface is added or removed.
-- Specifically, monitor the object tree to detect paths with the interface
-- "org.freedesktop.NetworkManager.Device.Tun".
module Xmobar.Plugins.VPN
( VPN (..)
, vpnAlias
, vpnDep
)
where
import DBus
import Data.Internal.DBus
import Data.Internal.XIO
import RIO
import qualified RIO.Map as M
import qualified RIO.Text as T
import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common
import Xmobar
import Xmobar.Plugins.Common
newtype VPN = VPN (T.Text, Colors) deriving (Read, Show)
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 formatter . Just =<< readState
s <- newEmptyMVar
mapRIO (VEnv c s dpy) $ do
initState
vpnAddedListener addedCallback
vpnRemovedListener removedCallback
dpy
where
formatter names = return $ case names of
[] -> colorText colors False text
xs -> T.unwords [T.intercalate "|" xs, colorText colors True text]
--------------------------------------------------------------------------------
-- VPN State
--
-- Maintain a set of paths which are the currently active VPNs. Most of the time
-- 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 c = VEnv
{ vClient :: !c
, vState :: !(MVar VPNState)
, vDisplay :: !(VIO ())
, vEnv :: !SimpleApp
}
instance HasLogFunc (VEnv c) where
logFuncL = lens vEnv (\x y -> x {vEnv = y}) . logFuncL
instance HasClient VEnv where
clientL = lens vClient (\x y -> x {vClient = y})
type VIO = RIO (VEnv SysClient)
type VPNState = M.Map ObjectPath T.Text
initState :: VIO ()
initState = do
ot <- getVPNObjectTree
s <- asks vState
putMVar s $ findTunnels ot
readState :: VIO [T.Text]
readState = M.elems <$> (readMVar =<< asks vState)
insertState :: ObjectPath -> T.Text -> VIO ()
insertState op name = do
s <- asks vState
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)
--------------------------------------------------------------------------------
-- Tunnel Device Detection
getVPNObjectTree
:: ( SafeClient c
, HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
=> m ObjectTree
getVPNObjectTree = callGetManagedObjects vpnBus vpnPath
findTunnels :: ObjectTree -> VPNState
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 InterfaceName (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
, HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
=> SignalCallback m
-> m ()
vpnAddedListener cb = void $ addInterfaceAddedListener vpnBus vpnPath cb
vpnRemovedListener
:: ( SafeClient c
, HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
=> SignalCallback m
-> m ()
vpnRemovedListener cb = void $ addInterfaceRemovedListener vpnBus vpnPath cb
addedCallback :: SignalCallback VIO
addedCallback [device, added] =
beforeDisplay $
forM_ (fromVariant device) $ \d ->
forM_ (lookupVPNInterface . M.mapKeys interfaceName_ =<< fromVariant added) $
insertState d
addedCallback _ = return ()
removedCallback :: SignalCallback VIO
removedCallback [device, _] =
beforeDisplay $ forM_ (fromVariant device) deleteState
removedCallback _ = return ()
--------------------------------------------------------------------------------
-- DBus Interface
vpnBus :: BusName
vpnBus = busName_ "org.freedesktop.NetworkManager"
vpnPath :: ObjectPath
vpnPath = objectPath_ "/org/freedesktop"
vpnDeviceTun :: InterfaceName
vpnDeviceTun = "org.freedesktop.NetworkManager.Device.Tun"
vpnDeviceParent :: InterfaceName
vpnDeviceParent = "org.freedesktop.NetworkManager.Device"
vpnAlias :: T.Text
vpnAlias = "vpn"
vpnDep :: DBusDependency_ SysClient
vpnDep =
Endpoint networkManagerPkgs networkManagerBus vpnPath omInterface $
Method_ getManagedObjects