REF merge plugin environ

This commit is contained in:
Nathan Dwarshuis 2023-10-01 00:24:33 -04:00
parent 2f6eeb5cdb
commit 700f42d65c
3 changed files with 71 additions and 68 deletions

View File

@ -34,7 +34,6 @@ import Xmobar.Plugins.ClevoKeyboard
import Xmobar.Plugins.Common import Xmobar.Plugins.Common
import Xmobar.Plugins.IntelBacklight import Xmobar.Plugins.IntelBacklight
import Xmobar.Plugins.Screensaver import Xmobar.Plugins.Screensaver
import Xmobar.Plugins.VPN
main :: IO () main :: IO ()
main = parse >>= xio main = parse >>= xio
@ -236,7 +235,7 @@ getBattery = iconIO_ "battery level indicator" xpfBattery root tree
fmap (Msg LevelError) <$> hasBattery fmap (Msg LevelError) <$> hasBattery
getVPN :: Maybe SysClient -> BarFeature getVPN :: Maybe SysClient -> BarFeature
getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root (Only_ vpnDep) getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root (Only_ devDep)
where where
root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl

View File

@ -33,50 +33,63 @@ newtype ActiveConnection
= ActiveConnection (NE.NonEmpty T.Text, T.Text, Colors) = ActiveConnection (NE.NonEmpty T.Text, T.Text, Colors)
deriving (Read, Show) 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 = displayMaybe cb formatter . Just =<< readState
i <- withDIO c $ initialState contypes
s <- newMVar i
let mapEnv c' = mapRIO (PluginEnv c' s dpy)
mapEnv c $ addListener mapEnv >> dpy
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 ->
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 :: ObjectPath
nmPath = objectPath_ "/org/freedesktop/NetworkManager" nmPath = "/org/freedesktop/NetworkManager"
nmInterface :: InterfaceName nmInterface :: InterfaceName
nmInterface = interfaceName_ "org.freedesktop.NetworkManager" nmInterface = "org.freedesktop.NetworkManager"
nmObjectTreePath :: ObjectPath
nmObjectTreePath = "/org/freedesktop"
nmActiveInterface :: InterfaceName nmActiveInterface :: InterfaceName
nmActiveInterface = nmActiveInterface = "org.freedesktop.NetworkManager.Connection.Active"
interfaceName_ "org.freedesktop.NetworkManager.Connection.Active"
stateChanged :: MemberName stateChanged :: MemberName
stateChanged = "StateChanged" stateChanged = "StateChanged"
getByIP :: MemberName -- semi-random method to test to ensure that NetworkManager is up and on DBus
getByIP = memberName_ "GetDeviceByIpIface"
devDep :: DBusDependency_ SysClient devDep :: DBusDependency_ SysClient
devDep = devDep =
Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface $ Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface $
Method_ getByIP Method_ "GetDeviceByIpIface"
-- -- TODO not DRY, make a NM specific section somewhere for this call type EthIO = PluginIO EthState SysClient
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 type EthState = M.Map ObjectPath T.Text
getConnectionProp :: MemberName -> ObjectPath -> EthIO [Variant] getConnectionProp :: MemberName -> ObjectPath -> EthIO [Variant]
getConnectionProp prop path = callPropertyGet ethBus path nmActiveInterface prop getConnectionProp prop path = callPropertyGet nmBus path nmActiveInterface prop
getConnectionId :: ObjectPath -> EthIO (Maybe T.Text) getConnectionId :: ObjectPath -> EthIO (Maybe T.Text)
getConnectionId = fmap fromSingletonVariant . getConnectionProp "Id" getConnectionId = fmap fromSingletonVariant . getConnectionProp "Id"
@ -87,25 +100,26 @@ getConnectionType = fmap fromSingletonVariant . getConnectionProp "Type"
updateConnected :: NE.NonEmpty T.Text -> ObjectPath -> EthIO () updateConnected :: NE.NonEmpty T.Text -> ObjectPath -> EthIO ()
updateConnected contypes path = do updateConnected contypes path = do
typeRes <- getConnectionType path typeRes <- getConnectionType path
case typeRes of logMaybe "type" getId typeRes
Nothing -> logError "could not get type" where
Just contype -> do 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 when (contype `elem` contypes) $ do
idRes <- getConnectionId path idRes <- getConnectionId path
case idRes of logMaybe "ID" insertId idRes
Nothing -> logError "could not get ID" insertId i = do
Just i -> do s <- asks plugState
s <- asks ethState
modifyMVar_ s $ return . M.insert path i modifyMVar_ s $ return . M.insert path i
updateDisconnected :: ObjectPath -> EthIO () updateDisconnected :: ObjectPath -> EthIO ()
updateDisconnected path = do updateDisconnected path = do
s <- asks ethState s <- asks plugState
modifyMVar_ s $ return . M.delete path modifyMVar_ s $ return . M.delete path
testActiveType :: NE.NonEmpty T.Text -> Signal -> EthIO () testActiveType :: NE.NonEmpty T.Text -> Signal -> EthIO ()
testActiveType contypes sig = do testActiveType contypes sig = do
dpy <- asks ethDisplay dpy <- asks plugDisplay
case signalBody sig of case signalBody sig of
[state, _] -> case fromVariant state of [state, _] -> case fromVariant state of
Just (2 :: Word32) -> updateConnected contypes path >> dpy Just (2 :: Word32) -> updateConnected contypes path >> dpy
@ -125,7 +139,7 @@ initialState
=> NE.NonEmpty T.Text => NE.NonEmpty T.Text
-> m EthState -> m EthState
initialState contypes = initialState contypes =
M.mapMaybe go <$> callGetManagedObjects ethBus "/org/freedesktop" M.mapMaybe go <$> callGetManagedObjects nmBus nmObjectTreePath
where where
go = getId <=< M.lookup nmActiveInterface go = getId <=< M.lookup nmActiveInterface
getId m = getId m =
@ -135,31 +149,4 @@ initialState contypes =
=<< M.lookup "Type" m =<< M.lookup "Type" m
readState :: EthIO [T.Text] readState :: EthIO [T.Text]
readState = M.elems <$> (readMVar =<< asks ethState) readState = M.elems <$> (readMVar =<< asks plugState)
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 = displayMaybe cb formatter . Just =<< readState
i <- withDIO c $ initialState contypes
s <- newMVar i
let mapEnv c' = mapRIO (EthEnv c' s dpy)
mapEnv c $ addListener mapEnv >> dpy
where
formatter names = return $ case names of
[] -> colorText colors False text
xs -> T.unwords [T.intercalate "|" xs, colorText colors True text]
addListener mapEnv = do
res <- matchSignalFull ethBus Nothing (Just nmActiveInterface) (Just stateChanged)
case res of
Nothing -> logError "could not start listener"
Just rule ->
void $
addMatchCallbackSignal rule $ \sig ->
withDBusClientConnection cb (Just "ethernet-cb.log") $ \c' ->
mapEnv c' $
testActiveType contypes sig

View File

@ -10,6 +10,8 @@ module Xmobar.Plugins.Common
, displayMaybe , displayMaybe
, displayMaybe' , displayMaybe'
, xmobarFGColor , xmobarFGColor
, PluginEnv (..)
, PluginIO
) )
where where
@ -21,6 +23,21 @@ import RIO
import qualified RIO.Text as T import qualified RIO.Text as T
import XMonad.Hooks.DynamicLog (xmobarColor) import XMonad.Hooks.DynamicLog (xmobarColor)
data PluginEnv s c = PluginEnv
{ plugClient :: !c
, plugState :: !(MVar s)
, plugDisplay :: !(PluginIO s c ())
, plugEnv :: !SimpleApp
}
type PluginIO s c = RIO (PluginEnv s c)
instance HasClient (PluginEnv s) where
clientL = lens plugClient (\x y -> x {plugClient = y})
instance HasLogFunc (PluginEnv s c) where
logFuncL = lens plugEnv (\x y -> x {plugEnv = y}) . logFuncL
-- use string here since all the callbacks in xmobar use strings :( -- use string here since all the callbacks in xmobar use strings :(
type Callback = String -> IO () type Callback = String -> IO ()