156 lines
5.2 KiB
Haskell
156 lines
5.2 KiB
Haskell
--------------------------------------------------------------------------------
|
|
-- NetworkManager Connection plugin
|
|
--
|
|
-- Show active connections of varying types.
|
|
--
|
|
-- This plugin exclusively monitors the */ActiveConnection/* paths in the
|
|
-- NetworkManager DBus path for state changes. It does not pin these to any
|
|
-- particular interface but instead looks at all connections equally and filters
|
|
-- based on their Type (ethernet, wifi, VPN, etc). For many use cases this will
|
|
-- track well enough with either one or a collection of similar interfaces (ie
|
|
-- all ethernet or all wifi).
|
|
|
|
module Xmobar.Plugins.ActiveConnection
|
|
( ActiveConnection (..)
|
|
, devDep
|
|
, connAlias
|
|
)
|
|
where
|
|
|
|
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 ActiveConnection
|
|
= ActiveConnection (NE.NonEmpty T.Text, T.Text, Colors)
|
|
deriving (Read, Show)
|
|
|
|
connAlias :: NE.NonEmpty T.Text -> T.Text
|
|
connAlias = T.intercalate "_" . NE.toList
|
|
|
|
instance Exec ActiveConnection where
|
|
alias (ActiveConnection (contypes, _, _)) = T.unpack $ connAlias contypes
|
|
start (ActiveConnection (contypes, text, colors)) cb =
|
|
withDBusClientConnection cb (Just "ethernet.log") $ \c -> do
|
|
let dpy cb' = displayMaybe cb' formatter . Just =<< readState
|
|
i <- withDIO c $ initialState contypes
|
|
s <- newMVar i
|
|
let mapEnv c' = mapRIO (PluginEnv c' s dpy cb)
|
|
mapEnv c $ addListener mapEnv >> pluginDisplay
|
|
where
|
|
formatter names = return $ case names of
|
|
[] -> colorText colors False text
|
|
xs -> T.unwords [colorText colors True text, T.intercalate "|" xs]
|
|
addListener mapEnv = do
|
|
res <- matchSignalFull nmBus Nothing (Just nmActiveInterface) (Just stateChanged)
|
|
case res of
|
|
Nothing -> logError "could not start listener"
|
|
Just rule ->
|
|
-- Start a new connection and RIO process since the parent thread
|
|
-- will have died before these callbacks fire, therefore the logging
|
|
-- file descriptor will be closed. This makes a new one
|
|
-- TODO can I recycle the client?
|
|
void $
|
|
addMatchCallbackSignal rule $ \sig ->
|
|
withDBusClientConnection cb (Just "ethernet-cb.log") $ \c' ->
|
|
mapEnv c' $
|
|
testActiveType contypes sig
|
|
|
|
nmBus :: BusName
|
|
nmBus = "org.freedesktop.NetworkManager"
|
|
|
|
nmPath :: ObjectPath
|
|
nmPath = "/org/freedesktop/NetworkManager"
|
|
|
|
nmInterface :: InterfaceName
|
|
nmInterface = "org.freedesktop.NetworkManager"
|
|
|
|
nmObjectTreePath :: ObjectPath
|
|
nmObjectTreePath = "/org/freedesktop"
|
|
|
|
nmActiveInterface :: InterfaceName
|
|
nmActiveInterface = "org.freedesktop.NetworkManager.Connection.Active"
|
|
|
|
stateChanged :: MemberName
|
|
stateChanged = "StateChanged"
|
|
|
|
-- semi-random method to test to ensure that NetworkManager is up and on DBus
|
|
devDep :: DBusDependency_ SysClient
|
|
devDep =
|
|
Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface $
|
|
Method_ "GetDeviceByIpIface"
|
|
|
|
type EthIO = PluginIO EthState SysClient
|
|
|
|
type EthState = M.Map ObjectPath T.Text
|
|
|
|
getConnectionProp :: MemberName -> ObjectPath -> EthIO [Variant]
|
|
getConnectionProp prop path = callPropertyGet nmBus 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
|
|
logMaybe "type" getId typeRes
|
|
where
|
|
path' = displayBytesUtf8 $ T.encodeUtf8 $ T.pack $ formatObjectPath path
|
|
logMaybe what = maybe (logError ("could not get " <> what <> " for " <> path'))
|
|
getId contype = do
|
|
when (contype `elem` contypes) $ do
|
|
idRes <- getConnectionId path
|
|
logMaybe "ID" insertId idRes
|
|
insertId i = do
|
|
s <- asks plugState
|
|
modifyMVar_ s $ return . M.insert path i
|
|
|
|
updateDisconnected :: ObjectPath -> EthIO ()
|
|
updateDisconnected path = do
|
|
s <- asks plugState
|
|
modifyMVar_ s $ return . M.delete path
|
|
|
|
testActiveType :: NE.NonEmpty T.Text -> Signal -> EthIO ()
|
|
testActiveType contypes sig = do
|
|
case signalBody sig of
|
|
[state, _] -> case fromVariant state of
|
|
Just (2 :: Word32) -> updateConnected contypes path >> pluginDisplay
|
|
Just 4 -> updateDisconnected path >> pluginDisplay
|
|
_ -> return ()
|
|
_ -> return ()
|
|
where
|
|
path = signalPath sig
|
|
|
|
initialState
|
|
:: ( SafeClient c
|
|
, MonadUnliftIO m
|
|
, MonadReader (env c) m
|
|
, HasClient env
|
|
, HasLogFunc (env c)
|
|
)
|
|
=> NE.NonEmpty T.Text
|
|
-> m EthState
|
|
initialState contypes =
|
|
M.mapMaybe go <$> callGetManagedObjects nmBus nmObjectTreePath
|
|
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
|
|
|
|
readState :: EthIO [T.Text]
|
|
readState = M.elems <$> (readMVar =<< asks plugState)
|