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

134 lines
4.1 KiB
Haskell
Raw Normal View History

{-# LANGUAGE OverloadedStrings #-}
2020-04-01 22:06:00 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- VPN plugin
2020-04-01 22:06:00 -04:00
--
2021-12-14 00:37:09 -05:00
-- 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".
2020-04-01 22:06:00 -04:00
module Xmobar.Plugins.VPN
2022-12-30 14:58:23 -05:00
( VPN (..)
, vpnAlias
, vpnDep
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:37:52 -05:00
import RIO
2022-12-31 19:47:02 -05:00
import qualified RIO.Map as M
import qualified RIO.Set as S
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
2020-03-21 18:37:26 -04:00
newtype VPN = VPN (T.Text, Colors) deriving (Read, Show)
2021-12-14 00:37:09 -05:00
instance Exec VPN where
alias (VPN _) = T.unpack vpnAlias
2021-12-14 00:37:09 -05:00
start (VPN (text, colors)) cb =
2022-07-09 17:08:10 -04:00
withDBusClientConnection cb $ \c -> do
2022-12-30 14:58:23 -05:00
state <- initState c
2022-12-30 16:37:52 -05:00
let dpy = displayMaybe cb iconFormatter . Just =<< readState state
let signalCallback' f = f state dpy
2022-12-30 14:58:23 -05:00
vpnAddedListener (signalCallback' addedCallback) c
vpnRemovedListener (signalCallback' removedCallback) c
2022-12-30 16:37:52 -05:00
dpy
2021-12-14 00:37:09 -05:00
where
iconFormatter b = return $ colorText colors b text
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- VPN State
2021-12-14 00:37:09 -05:00
--
-- 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.
type VPNState = S.Set ObjectPath
type MutableVPNState = MVar VPNState
2022-12-30 17:02:23 -05:00
initState :: MonadUnliftIO m => SysClient -> m MutableVPNState
2021-12-14 00:37:09 -05:00
initState client = do
ot <- getVPNObjectTree client
newMVar $ findTunnels ot
2022-12-30 17:02:23 -05:00
readState :: MonadUnliftIO m => MutableVPNState -> m Bool
2021-12-14 00:37:09 -05:00
readState = fmap (not . null) . readMVar
2022-12-30 14:58:23 -05:00
updateState
2022-12-30 16:37:52 -05:00
:: MonadUnliftIO m
=> (ObjectPath -> VPNState -> VPNState)
2022-12-30 14:58:23 -05:00
-> MutableVPNState
-> ObjectPath
2022-12-30 16:37:52 -05:00
-> m ()
2021-12-14 00:37:09 -05:00
updateState f state op = modifyMVar_ state $ return . f op
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Tunnel Device Detection
2021-12-14 00:37:09 -05:00
2022-12-30 17:02:23 -05:00
getVPNObjectTree :: MonadUnliftIO m => SysClient -> m ObjectTree
2022-07-09 17:44:14 -04:00
getVPNObjectTree sys = callGetManagedObjects sys vpnBus vpnPath
2021-12-14 00:37:09 -05:00
findTunnels :: ObjectTree -> VPNState
findTunnels = S.fromList . M.keys . M.filter (elem vpnDeviceTun . M.keys)
2022-12-30 16:37:52 -05:00
vpnAddedListener :: MonadUnliftIO m => SignalCallback m -> SysClient -> m ()
2022-07-09 17:44:14 -04:00
vpnAddedListener cb = void . addInterfaceAddedListener vpnBus vpnPath cb
2021-12-14 00:37:09 -05:00
2022-12-30 16:37:52 -05:00
vpnRemovedListener :: MonadUnliftIO m => SignalCallback m -> SysClient -> m ()
2022-07-09 17:44:14 -04:00
vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb
2021-12-14 00:37:09 -05:00
2022-12-30 16:37:52 -05:00
addedCallback :: MonadUnliftIO m => MutableVPNState -> m () -> SignalCallback m
addedCallback state dpy [device, added] = update >> dpy
2021-12-14 00:37:09 -05:00
where
added' = fromVariant added :: Maybe (M.Map T.Text (M.Map T.Text Variant))
2021-12-14 00:37:09 -05:00
is = M.keys $ fromMaybe M.empty added'
update = updateDevice S.insert state device is
2022-12-30 14:58:23 -05:00
addedCallback _ _ _ = return ()
2021-12-14 00:37:09 -05:00
2022-12-30 16:37:52 -05:00
removedCallback :: MonadUnliftIO m => MutableVPNState -> m () -> SignalCallback m
removedCallback state dpy [device, interfaces] = update >> dpy
2021-12-14 00:37:09 -05:00
where
is = fromMaybe [] $ fromVariant interfaces :: [T.Text]
2021-12-14 00:37:09 -05:00
update = updateDevice S.delete state device is
2022-12-30 14:58:23 -05:00
removedCallback _ _ _ = return ()
updateDevice
2022-12-30 16:37:52 -05:00
:: MonadUnliftIO m
=> (ObjectPath -> VPNState -> VPNState)
2022-12-30 14:58:23 -05:00
-> MutableVPNState
-> Variant
-> [T.Text]
2022-12-30 16:37:52 -05:00
-> m ()
2022-12-30 14:58:23 -05:00
updateDevice f state device interfaces =
when (vpnDeviceTun `elem` interfaces) $
forM_ d $
updateState f state
2021-12-14 00:37:09 -05:00
where
d = fromVariant device :: Maybe ObjectPath
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- DBus Interface
2021-12-14 00:37:09 -05:00
vpnBus :: BusName
vpnBus = busName_ "org.freedesktop.NetworkManager"
vpnPath :: ObjectPath
2021-12-14 00:37:09 -05:00
vpnPath = objectPath_ "/org/freedesktop"
vpnDeviceTun :: T.Text
2021-12-14 00:37:09 -05:00
vpnDeviceTun = "org.freedesktop.NetworkManager.Device.Tun"
vpnAlias :: T.Text
vpnAlias = "vpn"
2020-03-21 18:37:26 -04:00
2022-07-09 17:08:10 -04:00
vpnDep :: DBusDependency_ SysClient
2022-12-30 14:58:23 -05:00
vpnDep =
Endpoint networkManagerPkgs networkManagerBus vpnPath omInterface $
Method_ getManagedObjects