ENH use active connection plugin for both networkmanager and vpn connections

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 =
         , "<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
-    { 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

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
+-- 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
+  , 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
+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
       let dpy = displayMaybe cb formatter . Just =<< readState
       i <- withDIO c $ initialState contypes
       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
       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

lib/Xmobar/Plugins/VPN.hs

@@ -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