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

174 lines
4.5 KiB
Haskell
Raw Normal View History

2023-01-03 22:18:55 -05:00
{-# LANGUAGE FlexibleInstances #-}
{-# 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 =
2023-01-03 23:33:08 -05:00
withDBusClientConnection cb (Just "vpn.log") $ \c -> do
2023-01-02 10:33:04 -05:00
let dpy = displayMaybe cb iconFormatter . Just =<< readState
2023-01-03 22:28:34 -05:00
s <- newEmptyMVar
2023-01-03 22:18:55 -05:00
mapRIO (VEnv c s dpy) $ do
initState
vpnAddedListener addedCallback
vpnRemovedListener removedCallback
2023-01-02 10:33:04 -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.
2023-01-03 22:18:55 -05:00
data VEnv c = VEnv
{ vClient :: !c
2023-01-03 22:31:29 -05:00
, vState :: !(MVar VPNState)
2023-01-02 10:33:04 -05:00
, vDisplay :: !(VIO ())
, vEnv :: !SimpleApp
}
2023-01-03 22:32:43 -05:00
instance SafeClient c => HasLogFunc (VEnv c) where
2023-01-02 10:33:04 -05:00
logFuncL = lens vEnv (\x y -> x {vEnv = y}) . logFuncL
2023-01-03 22:18:55 -05:00
instance HasClient VEnv where
clientL = lens vClient (\x y -> x {vClient = y})
type VIO = RIO (VEnv SysClient)
2023-01-02 10:33:04 -05:00
2021-12-14 00:37:09 -05:00
type VPNState = S.Set ObjectPath
2023-01-03 22:18:55 -05:00
initState :: VIO ()
initState = do
ot <- getVPNObjectTree
s <- asks vState
putMVar s $ findTunnels ot
2021-12-14 00:37:09 -05:00
2023-01-02 10:33:04 -05:00
readState :: VIO Bool
readState = fmap (not . null) . readMVar =<< asks vState
2021-12-14 00:37:09 -05:00
2023-01-02 10:33:04 -05:00
updateState :: (ObjectPath -> VPNState -> VPNState) -> ObjectPath -> VIO ()
updateState f op = do
s <- asks vState
modifyMVar_ s $ return . f op
beforeDisplay :: VIO () -> VIO ()
beforeDisplay f = f >> join (asks vDisplay)
2021-12-14 00:37:09 -05:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Tunnel Device Detection
2021-12-14 00:37:09 -05:00
getVPNObjectTree
2023-01-03 22:18:55 -05:00
:: ( SafeClient c
, HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
=> m ObjectTree
getVPNObjectTree = callGetManagedObjects vpnBus vpnPath
2021-12-14 00:37:09 -05:00
findTunnels :: ObjectTree -> VPNState
findTunnels = S.fromList . M.keys . M.filter (elem vpnDeviceTun . M.keys)
2023-01-01 19:41:46 -05:00
vpnAddedListener
2023-01-03 22:18:55 -05:00
:: ( SafeClient c
, HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
2023-01-01 19:41:46 -05:00
=> SignalCallback m
-> m ()
2023-01-03 22:18:55 -05:00
vpnAddedListener cb = void $ addInterfaceAddedListener vpnBus vpnPath cb
2021-12-14 00:37:09 -05:00
2023-01-01 19:41:46 -05:00
vpnRemovedListener
2023-01-03 22:18:55 -05:00
:: ( SafeClient c
, HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
2023-01-01 19:41:46 -05:00
=> SignalCallback m
-> m ()
2023-01-03 22:18:55 -05:00
vpnRemovedListener cb = void $ addInterfaceRemovedListener vpnBus vpnPath cb
2021-12-14 00:37:09 -05:00
2023-01-02 10:33:04 -05:00
addedCallback :: SignalCallback VIO
addedCallback [device, added] =
beforeDisplay $
updateDevice S.insert device $
M.keys $
fromMaybe M.empty added'
2021-12-14 00:37:09 -05:00
where
added' = fromVariant added :: Maybe (M.Map T.Text (M.Map T.Text Variant))
2023-01-02 10:33:04 -05:00
addedCallback _ = return ()
2021-12-14 00:37:09 -05:00
2023-01-02 10:33:04 -05:00
removedCallback :: SignalCallback VIO
removedCallback [device, interfaces] =
beforeDisplay $
updateDevice S.delete device $
fromMaybe [] $
fromVariant interfaces
removedCallback _ = return ()
2022-12-30 14:58:23 -05:00
updateDevice
2023-01-02 10:33:04 -05:00
:: (ObjectPath -> VPNState -> VPNState)
2022-12-30 14:58:23 -05:00
-> Variant
-> [T.Text]
2023-01-02 10:33:04 -05:00
-> VIO ()
updateDevice f device interfaces =
2022-12-30 14:58:23 -05:00
when (vpnDeviceTun `elem` interfaces) $
forM_ d $
2023-01-02 10:33:04 -05:00
updateState f
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