ENH show VPN interface names

bin/xmobar.hs

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

lib/Xmobar/Plugins/VPN.hs

@@ -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 :: VIO [T.Text]
-readState = fmap (not . null) . readMVar =<< asks vState
+readState = M.elems <$> (readMVar =<< asks vState)
 
-updateState :: (ObjectPath -> VPNState -> VPNState) -> ObjectPath -> VIO ()
+-- updateState :: (ObjectPath -> VPNState -> VPNState) -> ObjectPath -> VIO ()
-updateState f op = do
+-- 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 $
+    forM_ (fromVariant device) $ \d ->
-      M.keys $
+      forM_ (lookupVPNInterface =<< fromVariant added) $
-        fromMaybe M.empty added'
+        insertState d
-  where
-    added' = fromVariant added :: Maybe (M.Map T.Text (M.Map T.Text Variant))
 addedCallback _ = return ()
 
 removedCallback :: SignalCallback VIO
-removedCallback [device, interfaces] =
+removedCallback [device, _] =
-  beforeDisplay $
+  beforeDisplay $ forM_ (fromVariant device) deleteState
-    updateDevice S.delete device $
-      fromMaybe [] $
-        fromVariant interfaces
 removedCallback _ = return ()
 
-updateDevice
+-- updateDevice
-  :: (ObjectPath -> VPNState -> VPNState)
+--   :: (ObjectPath -> VPNState -> VPNState)
-  -> Variant
+--   -> Variant
-  -> [T.Text]
+--   -> [T.Text]
-  -> VIO ()
+--   -> VIO ()
-updateDevice f device interfaces =
+-- updateDevice f device interfaces =
-  when (vpnDeviceTun `elem` interfaces) $
+--   when (vpnDeviceTun `elem` interfaces) $
-    forM_ d $
+--     forM_ d $
-      updateState f
+--       updateState f
-  where
+--   where
-    d = fromVariant device :: Maybe ObjectPath
+--     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"