ENH show network connection names

This commit is contained in:
Nathan Dwarshuis 2023-09-30 18:51:07 -04:00
parent 0a4edb6bf2
commit f814ac9217
4 changed files with 141 additions and 61 deletions

View File

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

View File

@ -10,6 +10,8 @@ module Data.Internal.DBus
, HasClient (..) , HasClient (..)
, withDIO , withDIO
, addMatchCallback , addMatchCallback
, addMatchCallbackSignal
, matchSignalFull
, matchProperty , matchProperty
, matchPropertyFull , matchPropertyFull
, matchPropertyChanged , matchPropertyChanged
@ -198,6 +200,19 @@ bodyToMaybe = either (const Nothing) fromSingletonVariant
type SignalCallback m = [Variant] -> m () 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 addMatchCallback
:: ( MonadReader (env c) m :: ( MonadReader (env c) m
, MonadUnliftIO m , MonadUnliftIO m
@ -207,10 +222,7 @@ addMatchCallback
=> MatchRule => MatchRule
-> SignalCallback m -> SignalCallback m
-> m SignalHandler -> 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 matchSignal
:: Maybe BusName :: Maybe BusName
@ -333,7 +345,7 @@ matchPropertyChanged _ _ _ = Failure
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Object Manager -- 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
omInterface = interfaceName_ "org.freedesktop.DBus.ObjectManager" omInterface = interfaceName_ "org.freedesktop.DBus.ObjectManager"
@ -363,7 +375,11 @@ callGetManagedObjects bus path = do
Left err -> do Left err -> do
logError $ Utf8Builder $ encodeUtf8Builder err logError $ Utf8Builder $ encodeUtf8Builder err
return M.empty return M.empty
Right v -> return $ fromMaybe M.empty $ fromSingletonVariant v Right v ->
return $
fmap (M.mapKeys interfaceName_) $
fromMaybe M.empty $
fromSingletonVariant v
addInterfaceChangedListener addInterfaceChangedListener
:: ( MonadReader (env c) m :: ( MonadReader (env c) m

View File

@ -14,13 +14,15 @@ import DBus
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.XIO import Data.Internal.XIO
import RIO import RIO
import qualified RIO.Map as M
import qualified RIO.NonEmpty as NE
import qualified RIO.Text as T import qualified RIO.Text as T
import XMonad.Internal.Command.Desktop import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Common
import Xmobar import Xmobar
import Xmobar.Plugins.Common 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
nmPath = objectPath_ "/org/freedesktop/NetworkManager" nmPath = objectPath_ "/org/freedesktop/NetworkManager"
@ -28,59 +30,120 @@ nmPath = objectPath_ "/org/freedesktop/NetworkManager"
nmInterface :: InterfaceName nmInterface :: InterfaceName
nmInterface = interfaceName_ "org.freedesktop.NetworkManager" 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
getByIP = memberName_ "GetDeviceByIpIface" getByIP = memberName_ "GetDeviceByIpIface"
devSignal :: T.Text
devSignal = "Ip4Connectivity"
devDep :: DBusDependency_ SysClient devDep :: DBusDependency_ SysClient
devDep = devDep =
Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface $ Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface $
Method_ getByIP 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 where
mc = path = signalPath sig
(methodCallBus networkManagerBus nmPath nmInterface getByIP)
{ methodCallBody = [toVariant iface]
}
getDeviceConnected initialState
:: ( SafeClient c :: ( SafeClient c
, HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m , 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 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 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 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" Nothing -> logError "could not start listener"
chooseColor' = return . (\s -> colorText colors s text) . (> 1)

View File

@ -105,7 +105,7 @@ findTunnels = M.mapMaybe lookupVPNInterface
-- | For the interface map underneath a given object path, try to lookup a -- | 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 -- 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 lookupVPNInterface m
| isJust $ M.lookup vpnDeviceTun m = | isJust $ M.lookup vpnDeviceTun m =
fromVariant =<< M.lookup "Interface" =<< M.lookup vpnDeviceParent m fromVariant =<< M.lookup "Interface" =<< M.lookup vpnDeviceParent m
@ -137,7 +137,7 @@ addedCallback :: SignalCallback VIO
addedCallback [device, added] = addedCallback [device, added] =
beforeDisplay $ beforeDisplay $
forM_ (fromVariant device) $ \d -> forM_ (fromVariant device) $ \d ->
forM_ (lookupVPNInterface =<< fromVariant added) $ forM_ (lookupVPNInterface . M.mapKeys interfaceName_ =<< fromVariant added) $
insertState d insertState d
addedCallback _ = return () addedCallback _ = return ()
@ -155,10 +155,10 @@ vpnBus = busName_ "org.freedesktop.NetworkManager"
vpnPath :: ObjectPath vpnPath :: ObjectPath
vpnPath = objectPath_ "/org/freedesktop" vpnPath = objectPath_ "/org/freedesktop"
vpnDeviceTun :: T.Text vpnDeviceTun :: InterfaceName
vpnDeviceTun = "org.freedesktop.NetworkManager.Device.Tun" vpnDeviceTun = "org.freedesktop.NetworkManager.Device.Tun"
vpnDeviceParent :: T.Text vpnDeviceParent :: InterfaceName
vpnDeviceParent = "org.freedesktop.NetworkManager.Device" vpnDeviceParent = "org.freedesktop.NetworkManager.Device"
vpnAlias :: T.Text vpnAlias :: T.Text