ENH use active connection plugin for both networkmanager and vpn connections
This commit is contained in:
parent
f814ac9217
commit
2f6eeb5cdb
|
@ -28,10 +28,10 @@ import Xmobar hiding
|
||||||
( iconOffset
|
( iconOffset
|
||||||
, run
|
, run
|
||||||
)
|
)
|
||||||
|
import Xmobar.Plugins.ActiveConnection
|
||||||
import Xmobar.Plugins.Bluetooth
|
import Xmobar.Plugins.Bluetooth
|
||||||
import Xmobar.Plugins.ClevoKeyboard
|
import Xmobar.Plugins.ClevoKeyboard
|
||||||
import Xmobar.Plugins.Common
|
import Xmobar.Plugins.Common
|
||||||
import Xmobar.Plugins.Device
|
|
||||||
import Xmobar.Plugins.IntelBacklight
|
import Xmobar.Plugins.IntelBacklight
|
||||||
import Xmobar.Plugins.Screensaver
|
import Xmobar.Plugins.Screensaver
|
||||||
import Xmobar.Plugins.VPN
|
import Xmobar.Plugins.VPN
|
||||||
|
@ -223,7 +223,7 @@ getEthernet :: Maybe SysClient -> BarFeature
|
||||||
getEthernet cl = iconDBus_ "ethernet status indicator" xpfEthernet root (Only_ devDep)
|
getEthernet cl = iconDBus_ "ethernet status indicator" xpfEthernet root (Only_ devDep)
|
||||||
where
|
where
|
||||||
root useIcon tree' =
|
root useIcon tree' =
|
||||||
DBusRoot_ (const $ ethernetCmd useIcon ("vlan" :| ["802-3-ethernet"])) tree' cl
|
DBusRoot_ (const $ ethernetCmd useIcon) tree' cl
|
||||||
|
|
||||||
getBattery :: BarFeature
|
getBattery :: BarFeature
|
||||||
getBattery = iconIO_ "battery level indicator" xpfBattery root tree
|
getBattery = iconIO_ "battery level indicator" xpfBattery root tree
|
||||||
|
@ -369,13 +369,19 @@ wirelessCmd iface =
|
||||||
, "<icon=wifi_%%.xpm/>"
|
, "<icon=wifi_%%.xpm/>"
|
||||||
]
|
]
|
||||||
|
|
||||||
ethernetCmd :: Fontifier -> NE.NonEmpty T.Text -> CmdSpec
|
ethernetCmd :: Fontifier -> CmdSpec
|
||||||
ethernetCmd fontify contypes =
|
ethernetCmd = connCmd "\xf0e8" "ETH" ("vlan" :| ["802-3-ethernet"])
|
||||||
|
|
||||||
|
vpnCmd :: Fontifier -> CmdSpec
|
||||||
|
vpnCmd = connCmd "\xf023" "VPN" ("tun" :| [])
|
||||||
|
|
||||||
|
connCmd :: T.Text -> T.Text -> NE.NonEmpty T.Text -> Fontifier -> CmdSpec
|
||||||
|
connCmd icon abbr contypes fontify =
|
||||||
CmdSpec
|
CmdSpec
|
||||||
{ csAlias = "connection"
|
{ csAlias = connAlias contypes
|
||||||
, csRunnable =
|
, csRunnable =
|
||||||
Run $
|
Run $
|
||||||
Device (contypes, fontify IconMedium "\xf0e8" "ETH", colors)
|
ActiveConnection (contypes, fontify IconMedium icon abbr, colors)
|
||||||
}
|
}
|
||||||
|
|
||||||
batteryCmd :: Fontifier -> CmdSpec
|
batteryCmd :: Fontifier -> CmdSpec
|
||||||
|
@ -411,13 +417,6 @@ batteryCmd fontify =
|
||||||
, fontify' "\xf1e6" "AC"
|
, fontify' "\xf1e6" "AC"
|
||||||
]
|
]
|
||||||
|
|
||||||
vpnCmd :: Fontifier -> CmdSpec
|
|
||||||
vpnCmd fontify =
|
|
||||||
CmdSpec
|
|
||||||
{ csAlias = vpnAlias
|
|
||||||
, csRunnable = Run $ VPN (fontify IconMedium "\xf023" "VPN", colors)
|
|
||||||
}
|
|
||||||
|
|
||||||
btCmd :: Fontifier -> CmdSpec
|
btCmd :: Fontifier -> CmdSpec
|
||||||
btCmd fontify =
|
btCmd fontify =
|
||||||
CmdSpec
|
CmdSpec
|
||||||
|
|
|
@ -1,12 +1,19 @@
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Device plugin
|
-- NetworkManager Connection plugin
|
||||||
--
|
--
|
||||||
-- Display different text depending on whether or not the interface has
|
-- Show active connections of varying types.
|
||||||
-- connectivity
|
--
|
||||||
|
-- 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.Device
|
module Xmobar.Plugins.ActiveConnection
|
||||||
( Device (..)
|
( ActiveConnection (..)
|
||||||
, devDep
|
, devDep
|
||||||
|
, connAlias
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -22,7 +29,9 @@ import XMonad.Internal.DBus.Common
|
||||||
import Xmobar
|
import Xmobar
|
||||||
import Xmobar.Plugins.Common
|
import Xmobar.Plugins.Common
|
||||||
|
|
||||||
newtype Device = Device (NE.NonEmpty T.Text, T.Text, Colors) deriving (Read, Show)
|
newtype ActiveConnection
|
||||||
|
= ActiveConnection (NE.NonEmpty T.Text, T.Text, Colors)
|
||||||
|
deriving (Read, Show)
|
||||||
|
|
||||||
nmPath :: ObjectPath
|
nmPath :: ObjectPath
|
||||||
nmPath = objectPath_ "/org/freedesktop/NetworkManager"
|
nmPath = objectPath_ "/org/freedesktop/NetworkManager"
|
||||||
|
@ -128,22 +137,29 @@ initialState contypes =
|
||||||
readState :: EthIO [T.Text]
|
readState :: EthIO [T.Text]
|
||||||
readState = M.elems <$> (readMVar =<< asks ethState)
|
readState = M.elems <$> (readMVar =<< asks ethState)
|
||||||
|
|
||||||
instance Exec Device where
|
connAlias :: NE.NonEmpty T.Text -> T.Text
|
||||||
alias (Device (_, _, _)) = "connection"
|
connAlias = T.intercalate "_" . NE.toList
|
||||||
start (Device (contypes, text, colors)) cb =
|
|
||||||
|
instance Exec ActiveConnection where
|
||||||
|
alias (ActiveConnection (contypes, _, _)) = T.unpack $ connAlias contypes
|
||||||
|
start (ActiveConnection (contypes, text, colors)) cb =
|
||||||
withDBusClientConnection cb (Just "ethernet.log") $ \c -> do
|
withDBusClientConnection cb (Just "ethernet.log") $ \c -> do
|
||||||
let dpy = displayMaybe cb formatter . Just =<< readState
|
let dpy = displayMaybe cb formatter . Just =<< readState
|
||||||
i <- withDIO c $ initialState contypes
|
i <- withDIO c $ initialState contypes
|
||||||
s <- newMVar i
|
s <- newMVar i
|
||||||
mapRIO (EthEnv c s dpy) $ do
|
let mapEnv c' = mapRIO (EthEnv c' s dpy)
|
||||||
addListener
|
mapEnv c $ addListener mapEnv >> dpy
|
||||||
dpy
|
|
||||||
where
|
where
|
||||||
formatter names = return $ case names of
|
formatter names = return $ case names of
|
||||||
[] -> colorText colors False text
|
[] -> colorText colors False text
|
||||||
xs -> T.unwords [T.intercalate "|" xs, colorText colors True text]
|
xs -> T.unwords [T.intercalate "|" xs, colorText colors True text]
|
||||||
addListener = do
|
addListener mapEnv = do
|
||||||
res <- matchSignalFull ethBus Nothing (Just nmActiveInterface) (Just stateChanged)
|
res <- matchSignalFull ethBus Nothing (Just nmActiveInterface) (Just stateChanged)
|
||||||
case res of
|
case res of
|
||||||
Just rule -> void $ addMatchCallbackSignal rule (testActiveType contypes)
|
|
||||||
Nothing -> logError "could not start listener"
|
Nothing -> logError "could not start listener"
|
||||||
|
Just rule ->
|
||||||
|
void $
|
||||||
|
addMatchCallbackSignal rule $ \sig ->
|
||||||
|
withDBusClientConnection cb (Just "ethernet-cb.log") $ \c' ->
|
||||||
|
mapEnv c' $
|
||||||
|
testActiveType contypes sig
|
|
@ -1,170 +0,0 @@
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
-- VPN plugin
|
|
||||||
--
|
|
||||||
-- Use the networkmanager to detect when a VPN interface is added or removed.
|
|
||||||
-- Specifically, monitor the object tree to detect paths with the interface
|
|
||||||
-- "org.freedesktop.NetworkManager.Device.Tun".
|
|
||||||
|
|
||||||
module Xmobar.Plugins.VPN
|
|
||||||
( VPN (..)
|
|
||||||
, vpnAlias
|
|
||||||
, vpnDep
|
|
||||||
)
|
|
||||||
where
|
|
||||||
|
|
||||||
import DBus
|
|
||||||
import Data.Internal.DBus
|
|
||||||
import Data.Internal.XIO
|
|
||||||
import RIO
|
|
||||||
import qualified RIO.Map as M
|
|
||||||
import qualified RIO.Text as T
|
|
||||||
import XMonad.Internal.Command.Desktop
|
|
||||||
import XMonad.Internal.DBus.Common
|
|
||||||
import Xmobar
|
|
||||||
import Xmobar.Plugins.Common
|
|
||||||
|
|
||||||
newtype VPN = VPN (T.Text, Colors) deriving (Read, Show)
|
|
||||||
|
|
||||||
instance Exec VPN where
|
|
||||||
alias (VPN _) = T.unpack vpnAlias
|
|
||||||
start (VPN (text, colors)) cb =
|
|
||||||
withDBusClientConnection cb (Just "vpn.log") $ \c -> do
|
|
||||||
let dpy = displayMaybe cb formatter . Just =<< readState
|
|
||||||
s <- newEmptyMVar
|
|
||||||
mapRIO (VEnv c s dpy) $ do
|
|
||||||
initState
|
|
||||||
vpnAddedListener addedCallback
|
|
||||||
vpnRemovedListener removedCallback
|
|
||||||
dpy
|
|
||||||
where
|
|
||||||
formatter names = return $ case names of
|
|
||||||
[] -> colorText colors False text
|
|
||||||
xs -> T.unwords [T.intercalate "|" xs, colorText colors True text]
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
-- VPN State
|
|
||||||
--
|
|
||||||
-- Maintain a set of paths which are the currently active VPNs. Most of the time
|
|
||||||
-- this will be a null or singleton set, but this setup could handle the edge
|
|
||||||
-- case of multiple VPNs being active at once without puking.
|
|
||||||
|
|
||||||
data VEnv c = VEnv
|
|
||||||
{ vClient :: !c
|
|
||||||
, vState :: !(MVar VPNState)
|
|
||||||
, vDisplay :: !(VIO ())
|
|
||||||
, vEnv :: !SimpleApp
|
|
||||||
}
|
|
||||||
|
|
||||||
instance HasLogFunc (VEnv c) where
|
|
||||||
logFuncL = lens vEnv (\x y -> x {vEnv = y}) . logFuncL
|
|
||||||
|
|
||||||
instance HasClient VEnv where
|
|
||||||
clientL = lens vClient (\x y -> x {vClient = y})
|
|
||||||
|
|
||||||
type VIO = RIO (VEnv SysClient)
|
|
||||||
|
|
||||||
type VPNState = M.Map ObjectPath T.Text
|
|
||||||
|
|
||||||
initState :: VIO ()
|
|
||||||
initState = do
|
|
||||||
ot <- getVPNObjectTree
|
|
||||||
s <- asks vState
|
|
||||||
putMVar s $ findTunnels ot
|
|
||||||
|
|
||||||
readState :: VIO [T.Text]
|
|
||||||
readState = M.elems <$> (readMVar =<< asks vState)
|
|
||||||
|
|
||||||
insertState :: ObjectPath -> T.Text -> VIO ()
|
|
||||||
insertState op name = do
|
|
||||||
s <- asks vState
|
|
||||||
modifyMVar_ s $ return . M.insert op name
|
|
||||||
|
|
||||||
deleteState :: ObjectPath -> VIO ()
|
|
||||||
deleteState op = do
|
|
||||||
s <- asks vState
|
|
||||||
modifyMVar_ s $ return . M.delete op
|
|
||||||
|
|
||||||
beforeDisplay :: VIO () -> VIO ()
|
|
||||||
beforeDisplay f = f >> join (asks vDisplay)
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
-- Tunnel Device Detection
|
|
||||||
|
|
||||||
getVPNObjectTree
|
|
||||||
:: ( SafeClient c
|
|
||||||
, HasClient env
|
|
||||||
, MonadReader (env c) m
|
|
||||||
, HasLogFunc (env c)
|
|
||||||
, MonadUnliftIO m
|
|
||||||
)
|
|
||||||
=> m ObjectTree
|
|
||||||
getVPNObjectTree = callGetManagedObjects vpnBus vpnPath
|
|
||||||
|
|
||||||
findTunnels :: ObjectTree -> VPNState
|
|
||||||
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 InterfaceName (M.Map T.Text Variant) -> Maybe T.Text
|
|
||||||
lookupVPNInterface m
|
|
||||||
| isJust $ M.lookup vpnDeviceTun m =
|
|
||||||
fromVariant =<< M.lookup "Interface" =<< M.lookup vpnDeviceParent m
|
|
||||||
| otherwise = Nothing
|
|
||||||
|
|
||||||
vpnAddedListener
|
|
||||||
:: ( SafeClient c
|
|
||||||
, HasClient env
|
|
||||||
, MonadReader (env c) m
|
|
||||||
, HasLogFunc (env c)
|
|
||||||
, MonadUnliftIO m
|
|
||||||
)
|
|
||||||
=> SignalCallback m
|
|
||||||
-> m ()
|
|
||||||
vpnAddedListener cb = void $ addInterfaceAddedListener vpnBus vpnPath cb
|
|
||||||
|
|
||||||
vpnRemovedListener
|
|
||||||
:: ( SafeClient c
|
|
||||||
, HasClient env
|
|
||||||
, MonadReader (env c) m
|
|
||||||
, HasLogFunc (env c)
|
|
||||||
, MonadUnliftIO m
|
|
||||||
)
|
|
||||||
=> SignalCallback m
|
|
||||||
-> m ()
|
|
||||||
vpnRemovedListener cb = void $ addInterfaceRemovedListener vpnBus vpnPath cb
|
|
||||||
|
|
||||||
addedCallback :: SignalCallback VIO
|
|
||||||
addedCallback [device, added] =
|
|
||||||
beforeDisplay $
|
|
||||||
forM_ (fromVariant device) $ \d ->
|
|
||||||
forM_ (lookupVPNInterface . M.mapKeys interfaceName_ =<< fromVariant added) $
|
|
||||||
insertState d
|
|
||||||
addedCallback _ = return ()
|
|
||||||
|
|
||||||
removedCallback :: SignalCallback VIO
|
|
||||||
removedCallback [device, _] =
|
|
||||||
beforeDisplay $ forM_ (fromVariant device) deleteState
|
|
||||||
removedCallback _ = return ()
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
-- DBus Interface
|
|
||||||
|
|
||||||
vpnBus :: BusName
|
|
||||||
vpnBus = busName_ "org.freedesktop.NetworkManager"
|
|
||||||
|
|
||||||
vpnPath :: ObjectPath
|
|
||||||
vpnPath = objectPath_ "/org/freedesktop"
|
|
||||||
|
|
||||||
vpnDeviceTun :: InterfaceName
|
|
||||||
vpnDeviceTun = "org.freedesktop.NetworkManager.Device.Tun"
|
|
||||||
|
|
||||||
vpnDeviceParent :: InterfaceName
|
|
||||||
vpnDeviceParent = "org.freedesktop.NetworkManager.Device"
|
|
||||||
|
|
||||||
vpnAlias :: T.Text
|
|
||||||
vpnAlias = "vpn"
|
|
||||||
|
|
||||||
vpnDep :: DBusDependency_ SysClient
|
|
||||||
vpnDep =
|
|
||||||
Endpoint networkManagerPkgs networkManagerBus vpnPath omInterface $
|
|
||||||
Method_ getManagedObjects
|
|
Loading…
Reference in New Issue