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 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 =
, "<icon=wifi_%%.xpm/>"
]
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

View File

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

View File

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

View File

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