ENH show network connection names

bin/xmobar.hs

@@ -14,6 +14,7 @@ import Data.Internal.XIO
 import Options.Applicative
 import RIO hiding (hFlush)
 import RIO.List
+import qualified RIO.NonEmpty as NE
 import qualified RIO.Text as T
 import XMonad.Config.Prime (enumFrom)
 import XMonad.Core hiding (config)
@@ -219,10 +220,10 @@ getWireless =
     [Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
 
 getEthernet :: Maybe SysClient -> BarFeature
-getEthernet cl = iconDBus "ethernet status indicator" xpfEthernet root tree
+getEthernet cl = iconDBus_ "ethernet status indicator" xpfEthernet root (Only_ devDep)
   where
-    root useIcon tree' = DBusRoot (const . ethernetCmd useIcon) tree' cl
+    root useIcon tree' =
-    tree = And1 (Only readEthernet) (Only_ devDep)
+      DBusRoot_ (const $ ethernetCmd useIcon ("vlan" :| ["802-3-ethernet"])) tree' cl
 
 getBattery :: BarFeature
 getBattery = iconIO_ "battery level indicator" xpfBattery root tree
@@ -297,13 +298,13 @@ iconIO_
   -> BarFeature
 iconIO_ = iconSometimes' And_ Only_
 
-iconDBus
+-- iconDBus
-  :: T.Text
+--   :: T.Text
-  -> XPQuery
+--   -> XPQuery
-  -> (Fontifier -> DBusTree c p -> Root CmdSpec)
+--   -> (Fontifier -> DBusTree c p -> Root CmdSpec)
-  -> DBusTree c p
+--   -> DBusTree c p
-  -> BarFeature
+--   -> BarFeature
-iconDBus = iconSometimes' And1 $ Only_ . DBusIO
+-- iconDBus = iconSometimes' And1 $ Only_ . DBusIO
 
 iconDBus_
   :: T.Text
@@ -368,13 +369,13 @@ wirelessCmd iface =
         , "<icon=wifi_%%.xpm/>"
         ]
 
-ethernetCmd :: Fontifier -> T.Text -> CmdSpec
+ethernetCmd :: Fontifier -> NE.NonEmpty T.Text -> CmdSpec
-ethernetCmd fontify iface =
+ethernetCmd fontify contypes =
   CmdSpec
-    { csAlias = iface
+    { csAlias = "connection"
     , csRunnable =
         Run $
-          Device (iface, fontify IconMedium "\xf0e8" "ETH", colors)
+          Device (contypes, fontify IconMedium "\xf0e8" "ETH", colors)
     }
 
 batteryCmd :: Fontifier -> CmdSpec

lib/Data/Internal/DBus.hs

@@ -10,6 +10,8 @@ module Data.Internal.DBus
   , HasClient (..)
   , withDIO
   , addMatchCallback
+  , addMatchCallbackSignal
+  , matchSignalFull
   , matchProperty
   , matchPropertyFull
   , matchPropertyChanged
@@ -198,6 +200,19 @@ bodyToMaybe = either (const Nothing) fromSingletonVariant
 
 type SignalCallback m = [Variant] -> m ()
 
+addMatchCallbackSignal
+  :: ( MonadReader (env c) m
+     , MonadUnliftIO m
+     , SafeClient c
+     , HasClient env
+     )
+  => MatchRule
+  -> (Signal -> m ())
+  -> m SignalHandler
+addMatchCallbackSignal rule cb = do
+  cl <- toClient <$> view clientL
+  withRunInIO $ \run -> addMatch cl rule $ run . cb
+
 addMatchCallback
   :: ( MonadReader (env c) m
      , MonadUnliftIO m
@@ -207,10 +222,7 @@ addMatchCallback
   => MatchRule
   -> SignalCallback m
   -> m SignalHandler
-addMatchCallback rule cb = do
+addMatchCallback rule cb = addMatchCallbackSignal rule (cb . signalBody)
-  cl <- toClient <$> view clientL
-  withRunInIO $ \run -> do
-    addMatch cl rule $ run . cb . signalBody
 
 matchSignal
   :: Maybe BusName
@@ -333,7 +345,7 @@ matchPropertyChanged _ _ _ = Failure
 --------------------------------------------------------------------------------
 -- Object Manager
 
-type ObjectTree = M.Map ObjectPath (M.Map T.Text (M.Map T.Text Variant))
+type ObjectTree = M.Map ObjectPath (M.Map InterfaceName (M.Map T.Text Variant))
 
 omInterface :: InterfaceName
 omInterface = interfaceName_ "org.freedesktop.DBus.ObjectManager"
@@ -363,7 +375,11 @@ callGetManagedObjects bus path = do
     Left err -> do
       logError $ Utf8Builder $ encodeUtf8Builder err
       return M.empty
-    Right v -> return $ fromMaybe M.empty $ fromSingletonVariant v
+    Right v ->
+      return $
+        fmap (M.mapKeys interfaceName_) $
+          fromMaybe M.empty $
+            fromSingletonVariant v
 
 addInterfaceChangedListener
   :: ( MonadReader (env c) m

lib/Xmobar/Plugins/Device.hs

@@ -14,13 +14,15 @@ import DBus
 import Data.Internal.DBus
 import Data.Internal.XIO
 import RIO
+import qualified RIO.Map as M
+import qualified RIO.NonEmpty as NE
 import qualified RIO.Text as T
 import XMonad.Internal.Command.Desktop
 import XMonad.Internal.DBus.Common
 import Xmobar
 import Xmobar.Plugins.Common
 
-newtype Device = Device (T.Text, T.Text, Colors) deriving (Read, Show)
+newtype Device = Device (NE.NonEmpty T.Text, T.Text, Colors) deriving (Read, Show)
 
 nmPath :: ObjectPath
 nmPath = objectPath_ "/org/freedesktop/NetworkManager"
@@ -28,59 +30,120 @@ nmPath = objectPath_ "/org/freedesktop/NetworkManager"
 nmInterface :: InterfaceName
 nmInterface = interfaceName_ "org.freedesktop.NetworkManager"
 
-nmDeviceInterface :: InterfaceName
+nmActiveInterface :: InterfaceName
-nmDeviceInterface = interfaceName_ "org.freedesktop.NetworkManager.Device"
+nmActiveInterface =
+  interfaceName_ "org.freedesktop.NetworkManager.Connection.Active"
+
+stateChanged :: MemberName
+stateChanged = "StateChanged"
 
 getByIP :: MemberName
 getByIP = memberName_ "GetDeviceByIpIface"
 
-devSignal :: T.Text
-devSignal = "Ip4Connectivity"
-
 devDep :: DBusDependency_ SysClient
 devDep =
   Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface $
     Method_ getByIP
 
-getDevice
+-- -- TODO not DRY, make a NM specific section somewhere for this call
-  :: (SafeClient c, HasClient env, MonadReader (env c) m, MonadUnliftIO m)
+ethBus :: BusName
-  => T.Text
+ethBus = busName_ "org.freedesktop.NetworkManager"
-  -> m (Maybe ObjectPath)
+
-getDevice iface = bodyToMaybe <$> callMethod' mc
+data EthEnv c = EthEnv
+  { ethClient :: !c
+  , ethState :: !(MVar EthState)
+  , ethDisplay :: !(EthIO ())
+  , ethEnv :: !SimpleApp
+  }
+
+instance HasLogFunc (EthEnv c) where
+  logFuncL = lens ethEnv (\x y -> x {ethEnv = y}) . logFuncL
+
+instance HasClient EthEnv where
+  clientL = lens ethClient (\x y -> x {ethClient = y})
+
+type EthIO = RIO (EthEnv SysClient)
+
+type EthState = M.Map ObjectPath T.Text
+
+getConnectionProp :: MemberName -> ObjectPath -> EthIO [Variant]
+getConnectionProp prop path = callPropertyGet ethBus path nmActiveInterface prop
+
+getConnectionId :: ObjectPath -> EthIO (Maybe T.Text)
+getConnectionId = fmap fromSingletonVariant . getConnectionProp "Id"
+
+getConnectionType :: ObjectPath -> EthIO (Maybe T.Text)
+getConnectionType = fmap fromSingletonVariant . getConnectionProp "Type"
+
+updateConnected :: NE.NonEmpty T.Text -> ObjectPath -> EthIO ()
+updateConnected contypes path = do
+  typeRes <- getConnectionType path
+  case typeRes of
+    Nothing -> logError "could not get type"
+    Just contype -> do
+      when (contype `elem` contypes) $ do
+        idRes <- getConnectionId path
+        case idRes of
+          Nothing -> logError "could not get ID"
+          Just i -> do
+            s <- asks ethState
+            modifyMVar_ s $ return . M.insert path i
+
+updateDisconnected :: ObjectPath -> EthIO ()
+updateDisconnected path = do
+  s <- asks ethState
+  modifyMVar_ s $ return . M.delete path
+
+testActiveType :: NE.NonEmpty T.Text -> Signal -> EthIO ()
+testActiveType contypes sig = do
+  dpy <- asks ethDisplay
+  case signalBody sig of
+    [state, _] -> case fromVariant state of
+      Just (2 :: Word32) -> updateConnected contypes path >> dpy
+      Just 4 -> updateDisconnected path >> dpy
+      _ -> return ()
+    _ -> return ()
   where
-    mc =
+    path = signalPath sig
-      (methodCallBus networkManagerBus nmPath nmInterface getByIP)
-        { methodCallBody = [toVariant iface]
-        }
 
-getDeviceConnected
+initialState
   :: ( SafeClient c
-     , HasClient env
-     , MonadReader (env c) m
-     , HasLogFunc (env c)
      , MonadUnliftIO m
+     , MonadReader (env c) m
+     , HasClient env
+     , HasLogFunc (env c)
      )
-  => ObjectPath
+  => NE.NonEmpty T.Text
-  -> m [Variant]
+  -> m EthState
-getDeviceConnected path =
+initialState contypes =
-  callPropertyGet networkManagerBus path nmDeviceInterface $
+  M.mapMaybe go <$> callGetManagedObjects ethBus "/org/freedesktop"
-    memberName_ $
+  where
-      T.unpack devSignal
+    go = getId <=< M.lookup nmActiveInterface
+    getId m =
+      fromVariant
+        =<< (\t -> if t `elem` contypes then M.lookup "Id" m else Nothing)
+        =<< fromVariant
+        =<< M.lookup "Type" m
 
-matchStatus :: [Variant] -> SignalMatch Word32
+readState :: EthIO [T.Text]
-matchStatus = matchPropertyChanged nmDeviceInterface devSignal
+readState = M.elems <$> (readMVar =<< asks ethState)
 
 instance Exec Device where
-  alias (Device (iface, _, _)) = T.unpack iface
+  alias (Device (_, _, _)) = "connection"
-  start (Device (iface, text, colors)) cb =
+  start (Device (contypes, text, colors)) cb =
-    withDBusClientConnection cb logName $ \(sys :: SysClient) -> withDIO sys $ do
+    withDBusClientConnection cb (Just "ethernet.log") $ \c -> do
-      path <- getDevice iface
+      let dpy = displayMaybe cb formatter . Just =<< readState
-      displayMaybe' cb listener path
+      i <- withDIO c $ initialState contypes
+      s <- newMVar i
+      mapRIO (EthEnv c s dpy) $ do
+        addListener
+        dpy
     where
-      logName = Just $ T.unpack $ T.concat ["device@", iface, ".log"]
+      formatter names = return $ case names of
-      listener path = do
+        [] -> colorText colors False text
-        res <- matchPropertyFull networkManagerBus (Just path)
+        xs -> T.unwords [T.intercalate "|" xs, colorText colors True text]
+      addListener = do
+        res <- matchSignalFull ethBus Nothing (Just nmActiveInterface) (Just stateChanged)
         case res of
-          Just rule -> startListener rule (getDeviceConnected path) matchStatus chooseColor' cb
+          Just rule -> void $ addMatchCallbackSignal rule (testActiveType contypes)
           Nothing -> logError "could not start listener"
-      chooseColor' = return . (\s -> colorText colors s text) . (> 1)

lib/Xmobar/Plugins/VPN.hs

@@ -105,7 +105,7 @@ 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.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
@@ -137,7 +137,7 @@ addedCallback :: SignalCallback VIO
 addedCallback [device, added] =
   beforeDisplay $
     forM_ (fromVariant device) $ \d ->
-      forM_ (lookupVPNInterface =<< fromVariant added) $
+      forM_ (lookupVPNInterface . M.mapKeys interfaceName_ =<< fromVariant added) $
         insertState d
 addedCallback _ = return ()
 
@@ -155,10 +155,10 @@ vpnBus = busName_ "org.freedesktop.NetworkManager"
 vpnPath :: ObjectPath
 vpnPath = objectPath_ "/org/freedesktop"
 
-vpnDeviceTun :: T.Text
+vpnDeviceTun :: InterfaceName
 vpnDeviceTun = "org.freedesktop.NetworkManager.Device.Tun"
 
-vpnDeviceParent :: T.Text
+vpnDeviceParent :: InterfaceName
 vpnDeviceParent = "org.freedesktop.NetworkManager.Device"
 
 vpnAlias :: T.Text