xmonad-config/lib/Xmobar/Plugins/ActiveConnection.hs

156 lines
5.2 KiB
Haskell
Raw Normal View History

2020-05-28 23:17:17 -04:00
--------------------------------------------------------------------------------
-- NetworkManager Connection plugin
2020-05-28 23:17:17 -04:00
--
-- 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 (..)
2022-07-09 17:08:10 -04:00
, devDep
, connAlias
2022-12-30 14:58:23 -05:00
)
where
import DBus
import Data.Internal.DBus
2023-01-01 18:33:02 -05:00
import Data.Internal.XIO
2022-12-30 16:59:50 -05:00
import RIO
2023-09-30 18:51:07 -04:00
import qualified RIO.Map as M
import qualified RIO.NonEmpty as NE
2022-12-30 14:58:23 -05:00
import qualified RIO.Text as T
import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common
import Xmobar
import Xmobar.Plugins.Common
2021-11-25 00:12:00 -05:00
newtype ActiveConnection
= ActiveConnection (NE.NonEmpty T.Text, T.Text, Colors)
deriving (Read, Show)
2021-11-25 00:12:00 -05:00
2023-10-01 00:24:33 -04:00
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
2023-10-01 01:02:06 -04:00
let dpy cb' = displayMaybe cb' formatter . Just =<< readState
2023-10-01 00:24:33 -04:00
i <- withDIO c $ initialState contypes
s <- newMVar i
2023-10-01 01:02:06 -04:00
let mapEnv c' = mapRIO (PluginEnv c' s dpy cb)
mapEnv c $ addListener mapEnv >> pluginDisplay
2023-10-01 00:24:33 -04:00
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 ->
2023-10-01 01:02:06 -04:00
-- 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?
2023-10-01 00:24:33 -04:00
void $
addMatchCallbackSignal rule $ \sig ->
withDBusClientConnection cb (Just "ethernet-cb.log") $ \c' ->
mapEnv c' $
testActiveType contypes sig
nmBus :: BusName
nmBus = "org.freedesktop.NetworkManager"
2021-11-25 00:12:00 -05:00
nmPath :: ObjectPath
2023-10-01 00:24:33 -04:00
nmPath = "/org/freedesktop/NetworkManager"
2020-05-28 23:17:17 -04:00
2021-11-25 00:12:00 -05:00
nmInterface :: InterfaceName
2023-10-01 00:24:33 -04:00
nmInterface = "org.freedesktop.NetworkManager"
nmObjectTreePath :: ObjectPath
nmObjectTreePath = "/org/freedesktop"
2023-09-30 18:51:07 -04:00
nmActiveInterface :: InterfaceName
2023-10-01 00:24:33 -04:00
nmActiveInterface = "org.freedesktop.NetworkManager.Connection.Active"
2023-09-30 18:51:07 -04:00
stateChanged :: MemberName
stateChanged = "StateChanged"
2020-05-28 23:17:17 -04:00
2023-10-01 00:24:33 -04:00
-- semi-random method to test to ensure that NetworkManager is up and on DBus
2022-07-09 17:08:10 -04:00
devDep :: DBusDependency_ SysClient
2022-12-30 14:58:23 -05:00
devDep =
Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface $
2023-10-01 00:24:33 -04:00
Method_ "GetDeviceByIpIface"
2023-09-30 18:51:07 -04:00
2023-10-01 00:24:33 -04:00
type EthIO = PluginIO EthState SysClient
2023-09-30 18:51:07 -04:00
type EthState = M.Map ObjectPath T.Text
getConnectionProp :: MemberName -> ObjectPath -> EthIO [Variant]
2023-10-01 00:24:33 -04:00
getConnectionProp prop path = callPropertyGet nmBus path nmActiveInterface prop
2023-09-30 18:51:07 -04:00
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
2023-10-01 00:24:33 -04:00
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
2023-09-30 18:51:07 -04:00
when (contype `elem` contypes) $ do
idRes <- getConnectionId path
2023-10-01 00:24:33 -04:00
logMaybe "ID" insertId idRes
insertId i = do
s <- asks plugState
modifyMVar_ s $ return . M.insert path i
2023-09-30 18:51:07 -04:00
updateDisconnected :: ObjectPath -> EthIO ()
updateDisconnected path = do
2023-10-01 00:24:33 -04:00
s <- asks plugState
2023-09-30 18:51:07 -04:00
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
2023-10-01 01:02:06 -04:00
Just (2 :: Word32) -> updateConnected contypes path >> pluginDisplay
Just 4 -> updateDisconnected path >> pluginDisplay
2023-09-30 18:51:07 -04:00
_ -> return ()
_ -> return ()
2021-11-25 00:12:00 -05:00
where
2023-09-30 18:51:07 -04:00
path = signalPath sig
2021-11-25 00:12:00 -05:00
2023-09-30 18:51:07 -04:00
initialState
2023-01-03 22:18:55 -05:00
:: ( SafeClient c
2023-09-30 18:51:07 -04:00
, MonadUnliftIO m
2023-01-03 22:18:55 -05:00
, MonadReader (env c) m
2023-09-30 18:51:07 -04:00
, HasClient env
2023-01-03 22:18:55 -05:00
, HasLogFunc (env c)
)
2023-09-30 18:51:07 -04:00
=> NE.NonEmpty T.Text
-> m EthState
initialState contypes =
2023-10-01 00:24:33 -04:00
M.mapMaybe go <$> callGetManagedObjects nmBus nmObjectTreePath
2023-09-30 18:51:07 -04:00
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
2021-11-25 00:12:00 -05:00
2023-09-30 18:51:07 -04:00
readState :: EthIO [T.Text]
2023-10-01 00:24:33 -04:00
readState = M.elems <$> (readMVar =<< asks plugState)