From 2f6eeb5cdb587fff1325136b4b43b2357622109c Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sat, 30 Sep 2023 23:52:52 -0400 Subject: [PATCH] ENH use active connection plugin for both networkmanager and vpn connections --- bin/xmobar.hs | 25 ++- .../{Device.hs => ActiveConnection.hs} | 44 +++-- lib/Xmobar/Plugins/VPN.hs | 170 ------------------ 3 files changed, 42 insertions(+), 197 deletions(-) rename lib/Xmobar/Plugins/{Device.hs => ActiveConnection.hs} (75%) delete mode 100644 lib/Xmobar/Plugins/VPN.hs diff --git a/bin/xmobar.hs b/bin/xmobar.hs index a5eb374..44550ba 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -28,10 +28,10 @@ import Xmobar hiding ( iconOffset , run ) +import Xmobar.Plugins.ActiveConnection import Xmobar.Plugins.Bluetooth import Xmobar.Plugins.ClevoKeyboard import Xmobar.Plugins.Common -import Xmobar.Plugins.Device import Xmobar.Plugins.IntelBacklight import Xmobar.Plugins.Screensaver import Xmobar.Plugins.VPN @@ -223,7 +223,7 @@ getEthernet :: Maybe SysClient -> BarFeature getEthernet cl = iconDBus_ "ethernet status indicator" xpfEthernet root (Only_ devDep) where root useIcon tree' = - DBusRoot_ (const $ ethernetCmd useIcon ("vlan" :| ["802-3-ethernet"])) tree' cl + DBusRoot_ (const $ ethernetCmd useIcon) tree' cl getBattery :: BarFeature getBattery = iconIO_ "battery level indicator" xpfBattery root tree @@ -369,13 +369,19 @@ wirelessCmd iface = , "" ] -ethernetCmd :: Fontifier -> NE.NonEmpty T.Text -> CmdSpec -ethernetCmd fontify contypes = +ethernetCmd :: Fontifier -> CmdSpec +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 - { csAlias = "connection" + { csAlias = connAlias contypes , csRunnable = Run $ - Device (contypes, fontify IconMedium "\xf0e8" "ETH", colors) + ActiveConnection (contypes, fontify IconMedium icon abbr, colors) } batteryCmd :: Fontifier -> CmdSpec @@ -411,13 +417,6 @@ batteryCmd fontify = , fontify' "\xf1e6" "AC" ] -vpnCmd :: Fontifier -> CmdSpec -vpnCmd fontify = - CmdSpec - { csAlias = vpnAlias - , csRunnable = Run $ VPN (fontify IconMedium "\xf023" "VPN", colors) - } - btCmd :: Fontifier -> CmdSpec btCmd fontify = CmdSpec diff --git a/lib/Xmobar/Plugins/Device.hs b/lib/Xmobar/Plugins/ActiveConnection.hs similarity index 75% rename from lib/Xmobar/Plugins/Device.hs rename to lib/Xmobar/Plugins/ActiveConnection.hs index 43aaa56..7eced94 100644 --- a/lib/Xmobar/Plugins/Device.hs +++ b/lib/Xmobar/Plugins/ActiveConnection.hs @@ -1,12 +1,19 @@ -------------------------------------------------------------------------------- --- Device plugin +-- NetworkManager Connection plugin -- --- Display different text depending on whether or not the interface has --- connectivity +-- Show active connections of varying types. +-- +-- 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 - ( Device (..) +module Xmobar.Plugins.ActiveConnection + ( ActiveConnection (..) , devDep + , connAlias ) where @@ -22,7 +29,9 @@ import XMonad.Internal.DBus.Common import Xmobar 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_ "/org/freedesktop/NetworkManager" @@ -128,22 +137,29 @@ initialState contypes = readState :: EthIO [T.Text] readState = M.elems <$> (readMVar =<< asks ethState) -instance Exec Device where - alias (Device (_, _, _)) = "connection" - start (Device (contypes, text, colors)) cb = +connAlias :: NE.NonEmpty T.Text -> T.Text +connAlias = T.intercalate "_" . NE.toList + +instance Exec ActiveConnection where + alias (ActiveConnection (contypes, _, _)) = T.unpack $ connAlias contypes + start (ActiveConnection (contypes, text, colors)) cb = withDBusClientConnection cb (Just "ethernet.log") $ \c -> do let dpy = displayMaybe cb formatter . Just =<< readState i <- withDIO c $ initialState contypes s <- newMVar i - mapRIO (EthEnv c s dpy) $ do - addListener - dpy + let mapEnv c' = mapRIO (EthEnv c' s dpy) + mapEnv c $ addListener mapEnv >> dpy where formatter names = return $ case names of [] -> colorText colors False text xs -> T.unwords [T.intercalate "|" xs, colorText colors True text] - addListener = do + addListener mapEnv = do res <- matchSignalFull ethBus Nothing (Just nmActiveInterface) (Just stateChanged) case res of - Just rule -> void $ addMatchCallbackSignal rule (testActiveType contypes) Nothing -> logError "could not start listener" + Just rule -> + void $ + addMatchCallbackSignal rule $ \sig -> + withDBusClientConnection cb (Just "ethernet-cb.log") $ \c' -> + mapEnv c' $ + testActiveType contypes sig diff --git a/lib/Xmobar/Plugins/VPN.hs b/lib/Xmobar/Plugins/VPN.hs deleted file mode 100644 index 705d6c7..0000000 --- a/lib/Xmobar/Plugins/VPN.hs +++ /dev/null @@ -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