ENH make VPN plugin more general
This commit is contained in:
parent
da091fb251
commit
10ddbc7de4
|
|
@ -1,7 +1,9 @@
|
|||
--------------------------------------------------------------------------------
|
||||
-- | VPN plugin
|
||||
--
|
||||
-- Use the NetworkManger interface on DBus to check status
|
||||
-- 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(..)
|
||||
|
|
@ -9,9 +11,15 @@ module Xmobar.Plugins.VPN
|
|||
, 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.Client
|
||||
import DBus.Internal
|
||||
|
||||
import XMonad.Internal.Dependency
|
||||
|
|
@ -20,32 +28,95 @@ 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 True 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 :: Client -> 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 :: Client -> IO ObjectTree
|
||||
getVPNObjectTree client = callGetManagedObjects client vpnBus vpnPath
|
||||
|
||||
findTunnels :: ObjectTree -> VPNState
|
||||
findTunnels = S.fromList . M.keys . M.filter (elem vpnDeviceTun . M.keys)
|
||||
|
||||
vpnAddedListener :: SignalCallback -> Client -> IO ()
|
||||
vpnAddedListener = fmap void . addInterfaceAddedListener vpnBus vpnPath
|
||||
|
||||
vpnRemovedListener :: SignalCallback -> Client -> IO ()
|
||||
vpnRemovedListener = fmap void . addInterfaceRemovedListener vpnBus vpnPath
|
||||
|
||||
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/NetworkManager"
|
||||
vpnPath = objectPath_ "/org/freedesktop"
|
||||
|
||||
vpnInterface :: InterfaceName
|
||||
vpnInterface = interfaceName_ "org.freedesktop.NetworkManager"
|
||||
|
||||
vpnConnType :: String
|
||||
vpnConnType = "PrimaryConnectionType"
|
||||
vpnDeviceTun :: String
|
||||
vpnDeviceTun = "org.freedesktop.NetworkManager.Device.Tun"
|
||||
|
||||
vpnAlias :: String
|
||||
vpnAlias = "vpn"
|
||||
|
||||
vpnDep :: DBusDep
|
||||
vpnDep = Endpoint vpnBus vpnPath vpnInterface $ Property_ vpnConnType
|
||||
|
||||
instance Exec VPN where
|
||||
alias (VPN _) = vpnAlias
|
||||
start (VPN (text, colors)) cb =
|
||||
withDBusClientConnection True cb $ \c -> do
|
||||
rule <- matchPropertyFull c vpnBus (Just vpnPath)
|
||||
-- TODO intelligently warn user
|
||||
forM_ rule $ \r -> startListener r getProp fromSignal chooseColor' cb c
|
||||
where
|
||||
getProp = callPropertyGet vpnBus vpnPath vpnInterface $ memberName_ vpnConnType
|
||||
fromSignal = matchPropertyChanged vpnInterface vpnConnType
|
||||
chooseColor' = return . (\s -> colorText colors s text) . ("vpn" ==)
|
||||
vpnDep = Endpoint vpnBus vpnPath omInterface $ Method_ getManagedObjects
|
||||
|
|
|
|||
Loading…
Reference in New Issue