171 lines
4.7 KiB
Haskell
171 lines
4.7 KiB
Haskell
--------------------------------------------------------------------------------
|
|
-- 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
|