125 lines
4.1 KiB
Haskell
125 lines
4.1 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 Control.Concurrent.MVar
|
|
import Control.Monad
|
|
|
|
import qualified Data.Map as M
|
|
import Data.Maybe
|
|
import qualified Data.Set as S
|
|
|
|
import DBus
|
|
import DBus.Internal
|
|
|
|
import XMonad.Internal.Command.Desktop
|
|
import XMonad.Internal.DBus.Common
|
|
import XMonad.Internal.Dependency
|
|
import Xmobar
|
|
import Xmobar.Plugins.Common
|
|
|
|
newtype VPN = VPN (String, Colors) deriving (Read, Show)
|
|
|
|
instance Exec VPN where
|
|
alias (VPN _) = vpnAlias
|
|
start (VPN (text, colors)) cb =
|
|
withDBusClientConnection cb $ \c -> do
|
|
state <- initState c
|
|
let display = displayMaybe cb iconFormatter . Just =<< readState state
|
|
let signalCallback' f = f state display
|
|
vpnAddedListener (signalCallback' addedCallback) c
|
|
vpnRemovedListener (signalCallback' removedCallback) c
|
|
display
|
|
where
|
|
iconFormatter b = return $ colorText colors b 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.
|
|
|
|
type VPNState = S.Set ObjectPath
|
|
|
|
type MutableVPNState = MVar VPNState
|
|
|
|
initState :: SysClient -> IO MutableVPNState
|
|
initState client = do
|
|
ot <- getVPNObjectTree client
|
|
newMVar $ findTunnels ot
|
|
|
|
readState :: MutableVPNState -> IO Bool
|
|
readState = fmap (not . null) . readMVar
|
|
|
|
updateState :: (ObjectPath -> VPNState -> VPNState) -> MutableVPNState
|
|
-> ObjectPath -> IO ()
|
|
updateState f state op = modifyMVar_ state $ return . f op
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Tunnel Device Detection
|
|
--
|
|
|
|
getVPNObjectTree :: SysClient -> IO ObjectTree
|
|
getVPNObjectTree client = callGetManagedObjects (toClient client) vpnBus vpnPath
|
|
|
|
findTunnels :: ObjectTree -> VPNState
|
|
findTunnels = S.fromList . M.keys . M.filter (elem vpnDeviceTun . M.keys)
|
|
|
|
vpnAddedListener :: SignalCallback -> SysClient -> IO ()
|
|
vpnAddedListener cb = void . addInterfaceAddedListener vpnBus vpnPath cb . toClient
|
|
|
|
vpnRemovedListener :: SignalCallback -> SysClient -> IO ()
|
|
vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb . toClient
|
|
|
|
addedCallback :: MutableVPNState -> IO () -> SignalCallback
|
|
addedCallback state display [device, added] = update >> display
|
|
where
|
|
added' = fromVariant added :: Maybe (M.Map String (M.Map String Variant))
|
|
is = M.keys $ fromMaybe M.empty added'
|
|
update = updateDevice S.insert state device is
|
|
addedCallback _ _ _ = return ()
|
|
|
|
removedCallback :: MutableVPNState -> IO () -> SignalCallback
|
|
removedCallback state display [device, interfaces] = update >> display
|
|
where
|
|
is = fromMaybe [] $ fromVariant interfaces :: [String]
|
|
update = updateDevice S.delete state device is
|
|
removedCallback _ _ _ = return ()
|
|
|
|
updateDevice :: (ObjectPath -> VPNState -> VPNState) -> MutableVPNState
|
|
-> Variant -> [String] -> IO ()
|
|
updateDevice f state device interfaces = when (vpnDeviceTun `elem` interfaces) $
|
|
forM_ d $ updateState f state
|
|
where
|
|
d = fromVariant device :: Maybe ObjectPath
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | DBus Interface
|
|
--
|
|
|
|
vpnBus :: BusName
|
|
vpnBus = busName_ "org.freedesktop.NetworkManager"
|
|
|
|
vpnPath :: ObjectPath
|
|
vpnPath = objectPath_ "/org/freedesktop"
|
|
|
|
vpnDeviceTun :: String
|
|
vpnDeviceTun = "org.freedesktop.NetworkManager.Device.Tun"
|
|
|
|
vpnAlias :: String
|
|
vpnAlias = "vpn"
|
|
|
|
vpnDep :: DBusDependency_ SysClient
|
|
vpnDep = Endpoint networkManagerPkgs networkManagerBus vpnPath omInterface
|
|
$ Method_ getManagedObjects
|