From f814ac921795ad67b22a9aa3ab3a35412cd7bd18 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sat, 30 Sep 2023 18:51:07 -0400 Subject: [PATCH] ENH show network connection names --- bin/xmobar.hs | 29 ++++---- lib/Data/Internal/DBus.hs | 28 +++++-- lib/Xmobar/Plugins/Device.hs | 137 +++++++++++++++++++++++++---------- lib/Xmobar/Plugins/VPN.hs | 8 +- 4 files changed, 141 insertions(+), 61 deletions(-) diff --git a/bin/xmobar.hs b/bin/xmobar.hs index 4455470..a5eb374 100644 --- a/bin/xmobar.hs +++ b/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 - tree = And1 (Only readEthernet) (Only_ devDep) + root useIcon tree' = + 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 - :: T.Text - -> XPQuery - -> (Fontifier -> DBusTree c p -> Root CmdSpec) - -> DBusTree c p - -> BarFeature -iconDBus = iconSometimes' And1 $ Only_ . DBusIO +-- iconDBus +-- :: T.Text +-- -> XPQuery +-- -> (Fontifier -> DBusTree c p -> Root CmdSpec) +-- -> DBusTree c p +-- -> BarFeature +-- iconDBus = iconSometimes' And1 $ Only_ . DBusIO iconDBus_ :: T.Text @@ -368,13 +369,13 @@ wirelessCmd iface = , "" ] -ethernetCmd :: Fontifier -> T.Text -> CmdSpec -ethernetCmd fontify iface = +ethernetCmd :: Fontifier -> NE.NonEmpty T.Text -> CmdSpec +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 diff --git a/lib/Data/Internal/DBus.hs b/lib/Data/Internal/DBus.hs index aad1503..241c230 100644 --- a/lib/Data/Internal/DBus.hs +++ b/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 - cl <- toClient <$> view clientL - withRunInIO $ \run -> do - addMatch cl rule $ run . cb . signalBody +addMatchCallback rule cb = addMatchCallbackSignal rule (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 diff --git a/lib/Xmobar/Plugins/Device.hs b/lib/Xmobar/Plugins/Device.hs index 6ce6fbb..43aaa56 100644 --- a/lib/Xmobar/Plugins/Device.hs +++ b/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 -nmDeviceInterface = interfaceName_ "org.freedesktop.NetworkManager.Device" +nmActiveInterface :: InterfaceName +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 - :: (SafeClient c, HasClient env, MonadReader (env c) m, MonadUnliftIO m) - => T.Text - -> m (Maybe ObjectPath) -getDevice iface = bodyToMaybe <$> callMethod' mc +-- -- TODO not DRY, make a NM specific section somewhere for this call +ethBus :: BusName +ethBus = busName_ "org.freedesktop.NetworkManager" + +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 = - (methodCallBus networkManagerBus nmPath nmInterface getByIP) - { methodCallBody = [toVariant iface] - } + path = signalPath sig -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 - -> m [Variant] -getDeviceConnected path = - callPropertyGet networkManagerBus path nmDeviceInterface $ - memberName_ $ - T.unpack devSignal + => NE.NonEmpty T.Text + -> m EthState +initialState contypes = + M.mapMaybe go <$> callGetManagedObjects ethBus "/org/freedesktop" + where + 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 -matchStatus = matchPropertyChanged nmDeviceInterface devSignal +readState :: EthIO [T.Text] +readState = M.elems <$> (readMVar =<< asks ethState) instance Exec Device where - alias (Device (iface, _, _)) = T.unpack iface - start (Device (iface, text, colors)) cb = - withDBusClientConnection cb logName $ \(sys :: SysClient) -> withDIO sys $ do - path <- getDevice iface - displayMaybe' cb listener path + alias (Device (_, _, _)) = "connection" + start (Device (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 where - logName = Just $ T.unpack $ T.concat ["device@", iface, ".log"] - listener path = do - res <- matchPropertyFull networkManagerBus (Just path) + formatter names = return $ case names of + [] -> colorText colors False text + 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) diff --git a/lib/Xmobar/Plugins/VPN.hs b/lib/Xmobar/Plugins/VPN.hs index c57b8d4..705d6c7 100644 --- a/lib/Xmobar/Plugins/VPN.hs +++ b/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